diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for brittany +## 0.14.0.0 -- November 2021 + +* #357: Added support for GHC 9.0. Dropped support for all other versions of GHC. + * ab59e9acc3069551ac4132321b285d000f5f5691: Removed runtime dependency on `ghc-paths`. + * fa8365a7fa9372043d5a1018f2f7669ce3853edd: Started providing pre-built binaries for Linux, MacOS, and Windows. + * Many other changes to Brittany's internals and exposed Haskell interface, but (hopefully) no changes to its command-line interface. + ## 0.13.1.2 -- May 2021 * #347: Allowed hspec 2.8. Thanks @felixonmars! diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ # Other usage notes -- Supports GHC versions `8.6`, `8.8`, `8.10`. +- Supports GHC version `9.0.x`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. @@ -65,14 +65,7 @@ ~~~~ If you use an lts that includes brittany this should just work; otherwise - you may want to clone the repo and try again (there are several stack.yamls - included). - -- via `nix`: - ~~~.sh - nix build - nix-env -i ./result - ~~~ + you may want to clone the repo and try again. - via `cabal` @@ -102,18 +95,6 @@ ~~~~ # Development tips - -## Run a hoogle server - -To host a local Hoogle server with all of Brittany's dependencies run: - -```sh -echo brittany.cabal | - $(nix-build '' --no-link -A entr)/bin/entr -r -- \ - sh -c "nix-shell --run 'hoogle server --local'" -``` - -This will watch `brittany.cabal` for changes and restart the server when new dependencies are added there. # Editor Integration diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/brittany.cabal b/brittany.cabal --- a/brittany.cabal +++ b/brittany.cabal @@ -1,14 +1,15 @@ +cabal-version: 2.2 + name: brittany -version: 0.13.1.2 +version: 0.14.0.0 synopsis: Haskell source code formatter -description: { +description: See . . If you are interested in the implementation, have a look at ; . The implementation is documented in more detail . -} -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner @@ -16,326 +17,133 @@ Copyright (C) 2019 PRODA LTD category: Language build-type: Simple -cabal-version: 1.18 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues -extra-doc-files: { +extra-doc-files: ChangeLog.md README.md doc/implementation/*.md -} -extra-source-files: { - src-literatetests/*.blt - srcinc/prelude.inc -} +extra-source-files: + data/brittany.yaml + data/*.hs -source-repository head { +source-repository head type: git location: https://github.com/lspitzner/brittany.git -} -flag brittany-dev-lib - description: set buildable false for anything but lib +flag pedantic default: False + description: Enables @-Werror@, which turns warnings into errors. manual: True -flag brittany-test-perf - description: determines if performance test suite is enabled - default: False - manual: True +common library + build-depends: + , aeson ^>= 2.0.1 + , base ^>= 4.15.0 + , butcher ^>= 1.3.3 + , bytestring ^>= 0.10.12 + , cmdargs ^>= 0.10.21 + , containers ^>= 0.6.4 + , czipwith ^>= 1.0.1 + , data-tree-print ^>= 0.1.0 + , deepseq ^>= 1.4.5 + , directory ^>= 1.3.6 + , extra ^>= 1.7.10 + , filepath ^>= 1.4.2 + , ghc ^>= 9.0.1 + , ghc-boot ^>= 9.0.1 + , ghc-boot-th ^>= 9.0.1 + , ghc-exactprint ^>= 0.6.4 + , monad-memo ^>= 0.5.3 + , mtl ^>= 2.2.2 + , multistate ^>= 0.8.0 + , pretty ^>= 1.1.3 + , random ^>= 1.2.1 + , safe ^>= 0.3.19 + , semigroups ^>= 0.19.2 + , strict ^>= 0.4.0 + , syb ^>= 0.7.2 + , text ^>= 1.2.5 + , transformers ^>= 0.5.6 + , uniplate ^>= 1.6.13 + , yaml ^>= 0.11.7 + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-incomplete-uni-patterns + -Wno-missing-deriving-strategies + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-safe-haskell-mode + -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module + -Wno-safe + -Wno-unsafe -library { - default-language: - Haskell2010 - hs-source-dirs: - src - include-dirs: - srcinc - exposed-modules: { + if flag(pedantic) + ghc-options: -Werror + +common executable + import: library + + build-depends: brittany + ghc-options: + -rtsopts + -threaded + -Wno-implicit-prelude + -Wno-unused-packages + +library + import: library + + autogen-modules: Paths_brittany + hs-source-dirs: source/library + exposed-modules: Language.Haskell.Brittany - Language.Haskell.Brittany.Main Language.Haskell.Brittany.Internal - Language.Haskell.Brittany.Internal.Prelude - Language.Haskell.Brittany.Internal.PreludeUtils - Language.Haskell.Brittany.Internal.Types - Language.Haskell.Brittany.Internal.Utils + Language.Haskell.Brittany.Internal.Backend + Language.Haskell.Brittany.Internal.BackendUtils Language.Haskell.Brittany.Internal.Config Language.Haskell.Brittany.Internal.Config.Types Language.Haskell.Brittany.Internal.Config.Types.Instances - Language.Haskell.Brittany.Internal.Obfuscation - Paths_brittany - } - other-modules: { - Language.Haskell.Brittany.Internal.LayouterBasics - Language.Haskell.Brittany.Internal.Backend - Language.Haskell.Brittany.Internal.BackendUtils Language.Haskell.Brittany.Internal.ExactPrintUtils - Language.Haskell.Brittany.Internal.Layouters.Type + Language.Haskell.Brittany.Internal.LayouterBasics + Language.Haskell.Brittany.Internal.Layouters.DataDecl Language.Haskell.Brittany.Internal.Layouters.Decl Language.Haskell.Brittany.Internal.Layouters.Expr - Language.Haskell.Brittany.Internal.Layouters.Stmt - Language.Haskell.Brittany.Internal.Layouters.Pattern Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Module - Language.Haskell.Brittany.Internal.Layouters.DataDecl + Language.Haskell.Brittany.Internal.Layouters.Pattern + Language.Haskell.Brittany.Internal.Layouters.Stmt + Language.Haskell.Brittany.Internal.Layouters.Type + Language.Haskell.Brittany.Internal.Obfuscation + Language.Haskell.Brittany.Internal.ParseModule + Language.Haskell.Brittany.Internal.Prelude + Language.Haskell.Brittany.Internal.PreludeUtils Language.Haskell.Brittany.Internal.Transformations.Alt - Language.Haskell.Brittany.Internal.Transformations.Floating - Language.Haskell.Brittany.Internal.Transformations.Par Language.Haskell.Brittany.Internal.Transformations.Columns + Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Indent - } - ghc-options: { - -Wall - -fno-warn-unused-imports - -fno-warn-redundant-constraints - } - build-depends: - { base >=4.12 && <4.15 - , ghc >=8.6.1 && <8.11 - , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.6.5 - , transformers >=0.5.2.0 && <0.6 - , containers >=0.5.7.1 && <0.7 - , mtl >=2.2.1 && <2.3 - , text >=1.2 && <1.3 - , multistate >=0.7.1.1 && <0.9 - , syb >=0.6 && <0.8 - , data-tree-print - , pretty >=1.1.3.3 && <1.2 - , bytestring >=0.10.8.1 && <0.11 - , directory >=1.2.6.2 && <1.4 - , butcher >=1.3.1 && <1.4 - , yaml >=0.8.18 && <0.12 - , aeson >=1.0.1.0 && <1.6 - , extra >=1.4.10 && <1.8 - , uniplate >=1.6.12 && <1.7 - , strict >=0.3.2 && <0.5 - , monad-memo >=0.4.1 && <0.6 - , unsafe >=0.0 && <0.1 - , safe >=0.3.9 && <0.4 - , deepseq >=1.4.2.0 && <1.5 - , semigroups >=0.18.2 && <0.20 - , cmdargs >=0.10.14 && <0.11 - , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.6.1 && <8.11 - , filepath >=1.4.1.0 && <1.5 - , random >= 1.1 && <1.3 - } - default-extensions: { - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } -} + Language.Haskell.Brittany.Internal.Transformations.Par + Language.Haskell.Brittany.Internal.Types + Language.Haskell.Brittany.Internal.Utils + Language.Haskell.Brittany.Main + Paths_brittany executable brittany - if flag(brittany-dev-lib) { - buildable: False - } else { - buildable: True - } - main-is: Main.hs - hs-source-dirs: src-brittany - build-depends: - { base - , brittany - } - default-language: Haskell2010 - ghc-options: { - -Wall - -fno-spec-constr - -fno-warn-unused-imports - -fno-warn-redundant-constraints - -rtsopts - -with-rtsopts "-M2G" - } - -test-suite unittests - if flag(brittany-dev-lib) || !flag(brittany-test-perf) { - buildable: False - } else { - buildable: True - } - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: - { brittany - , base - , ghc - , ghc-paths - , ghc-exactprint - , transformers - , containers - , mtl - , text - , multistate - , syb - , data-tree-print - , pretty - , bytestring - , directory - , butcher - , yaml - , aeson - , extra - , uniplate - , strict - , monad-memo - , unsafe - , safe - , deepseq - , semigroups - , cmdargs - , czipwith - , ghc-boot-th - , hspec >=2.4.1 && <2.9 - } - main-is: TestMain.hs - other-modules: TestUtils - AsymptoticPerfTests - hs-source-dirs: src-unittests - include-dirs: srcinc - default-extensions: { - CPP - - NoImplicitPrelude + import: executable - GADTs + hs-source-dirs: source/executable + main-is: Main.hs - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } - ghc-options: { - -Wall - -fno-warn-unused-imports - -rtsopts - -with-rtsopts "-M2G" - -threaded - -- ^ threaded is not necessary at all, but our CI trusts on being able - -- to pass -N1, which is not possible without threaded :-/ - -- (plus -no-threaded is not a thing, afaict) - } +test-suite brittany-test-suite + import: executable -test-suite littests - if flag(brittany-dev-lib) { - buildable: False - } else { - buildable: True - } - type: exitcode-stdio-1.0 - default-language: Haskell2010 build-depends: - { brittany - , base - , ghc - , ghc-paths - , ghc-exactprint - , transformers - , containers - , mtl - , text - , multistate - , syb - , data-tree-print - , pretty - , bytestring - , directory - , butcher - , yaml - , aeson - , extra - , uniplate - , strict - , monad-memo - , unsafe - , safe - , deepseq - , semigroups - , cmdargs - , czipwith - , ghc-boot-th - , hspec >=2.4.1 && <2.9 - , filepath - , parsec >=3.1.11 && <3.2 - } - main-is: Main.hs - other-modules: - hs-source-dirs: src-literatetests - include-dirs: srcinc - default-extensions: { - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } - ghc-options: { - -Wall - -fno-warn-unused-imports - -threaded - -rtsopts - -with-rtsopts "-M2G -N" - } - -test-suite libinterfacetests - if flag(brittany-dev-lib) { - buildable: False - } else { - buildable: True - } - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: - { brittany - , base - , text - , transformers - , hspec >=2.4.1 && <2.9 - } - main-is: Main.hs - other-modules: - hs-source-dirs: src-libinterfacetests - include-dirs: srcinc - default-extensions: { - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } - ghc-options: { - -Wall - -fno-warn-unused-imports - -rtsopts - -with-rtsopts "-M2G" - -threaded - -- ^ threaded is not necessary at all, but our CI trusts on being able - -- to pass -N1, which is not possible without threaded :-/ - -- (plus -no-threaded is not a thing, afaict) - } + , hspec ^>= 2.8.3 + hs-source-dirs: source/test-suite + main-is: Main.hs + type: exitcode-stdio-1.0 diff --git a/data/Test1.hs b/data/Test1.hs new file mode 100644 --- /dev/null +++ b/data/Test1.hs @@ -0,0 +1,1 @@ +func :: a -> a diff --git a/data/Test10.hs b/data/Test10.hs new file mode 100644 --- /dev/null +++ b/data/Test10.hs @@ -0,0 +1,3 @@ +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) diff --git a/data/Test100.hs b/data/Test100.hs new file mode 100644 --- /dev/null +++ b/data/Test100.hs @@ -0,0 +1,1 @@ +func = klajsdas klajsdas klajsdas diff --git a/data/Test101.hs b/data/Test101.hs new file mode 100644 --- /dev/null +++ b/data/Test101.hs @@ -0,0 +1,3 @@ +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd diff --git a/data/Test102.hs b/data/Test102.hs new file mode 100644 --- /dev/null +++ b/data/Test102.hs @@ -0,0 +1,3 @@ +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas + lakjsdlajsdljas + lakjsdlajsdljas diff --git a/data/Test103.hs b/data/Test103.hs new file mode 100644 --- /dev/null +++ b/data/Test103.hs @@ -0,0 +1,1 @@ +func = (1 +) diff --git a/data/Test104.hs b/data/Test104.hs new file mode 100644 --- /dev/null +++ b/data/Test104.hs @@ -0,0 +1,1 @@ +func = (+ 1) diff --git a/data/Test105.hs b/data/Test105.hs new file mode 100644 --- /dev/null +++ b/data/Test105.hs @@ -0,0 +1,1 @@ +func = (1 `abc`) diff --git a/data/Test106.hs b/data/Test106.hs new file mode 100644 --- /dev/null +++ b/data/Test106.hs @@ -0,0 +1,1 @@ +func = (`abc` 1) diff --git a/data/Test107.hs b/data/Test107.hs new file mode 100644 --- /dev/null +++ b/data/Test107.hs @@ -0,0 +1,1 @@ +func = (abc, def) diff --git a/data/Test108.hs b/data/Test108.hs new file mode 100644 --- /dev/null +++ b/data/Test108.hs @@ -0,0 +1,1 @@ +func = (abc, ) diff --git a/data/Test109.hs b/data/Test109.hs new file mode 100644 --- /dev/null +++ b/data/Test109.hs @@ -0,0 +1,1 @@ +func = (, abc) diff --git a/data/Test11.hs b/data/Test11.hs new file mode 100644 --- /dev/null +++ b/data/Test11.hs @@ -0,0 +1,3 @@ +func + :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) + -> lakjsdlkjasldkj diff --git a/data/Test110.hs b/data/Test110.hs new file mode 100644 --- /dev/null +++ b/data/Test110.hs @@ -0,0 +1,6 @@ +myTupleSection = + ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement + , + , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement + , + ) diff --git a/data/Test111.hs b/data/Test111.hs new file mode 100644 --- /dev/null +++ b/data/Test111.hs @@ -0,0 +1,4 @@ +func = + ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + ) diff --git a/data/Test112.hs b/data/Test112.hs new file mode 100644 --- /dev/null +++ b/data/Test112.hs @@ -0,0 +1,6 @@ +foo = if True + then + -- iiiiii + "a " + else + "b " diff --git a/data/Test113.hs b/data/Test113.hs new file mode 100644 --- /dev/null +++ b/data/Test113.hs @@ -0,0 +1,5 @@ +func = if cond + then pure 42 + else do + -- test + abc diff --git a/data/Test114.hs b/data/Test114.hs new file mode 100644 --- /dev/null +++ b/data/Test114.hs @@ -0,0 +1,3 @@ +func = case x of + False -> False + True -> True diff --git a/data/Test115.hs b/data/Test115.hs new file mode 100644 --- /dev/null +++ b/data/Test115.hs @@ -0,0 +1,7 @@ +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True diff --git a/data/Test116.hs b/data/Test116.hs new file mode 100644 --- /dev/null +++ b/data/Test116.hs @@ -0,0 +1,7 @@ +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True diff --git a/data/Test117.hs b/data/Test117.hs new file mode 100644 --- /dev/null +++ b/data/Test117.hs @@ -0,0 +1,1 @@ +func = case x of {} diff --git a/data/Test118.hs b/data/Test118.hs new file mode 100644 --- /dev/null +++ b/data/Test118.hs @@ -0,0 +1,5 @@ +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} diff --git a/data/Test119.hs b/data/Test119.hs new file mode 100644 --- /dev/null +++ b/data/Test119.hs @@ -0,0 +1,5 @@ +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} diff --git a/data/Test12.hs b/data/Test12.hs new file mode 100644 --- /dev/null +++ b/data/Test12.hs @@ -0,0 +1,5 @@ +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> lakjsdlkjasldkj diff --git a/data/Test120.hs b/data/Test120.hs new file mode 100644 --- /dev/null +++ b/data/Test120.hs @@ -0,0 +1,3 @@ +func = do + stmt + stmt diff --git a/data/Test121.hs b/data/Test121.hs new file mode 100644 --- /dev/null +++ b/data/Test121.hs @@ -0,0 +1,3 @@ +func = do + x <- stmt + stmt x diff --git a/data/Test122.hs b/data/Test122.hs new file mode 100644 --- /dev/null +++ b/data/Test122.hs @@ -0,0 +1,3 @@ +func = do + let x = 13 + stmt x diff --git a/data/Test123.hs b/data/Test123.hs new file mode 100644 --- /dev/null +++ b/data/Test123.hs @@ -0,0 +1,7 @@ +func = + foooooo + $ [ case + foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + of + _ -> True + ] diff --git a/data/Test124.hs b/data/Test124.hs new file mode 100644 --- /dev/null +++ b/data/Test124.hs @@ -0,0 +1,4 @@ +testMethod foo bar baz qux = + let x = undefined foo bar baz qux qux baz bar :: String + -- some comment explaining the in expression + in undefined foo x :: String diff --git a/data/Test125.hs b/data/Test125.hs new file mode 100644 --- /dev/null +++ b/data/Test125.hs @@ -0,0 +1,4 @@ +testMethod foo bar baz qux = + let x = undefined :: String + -- some comment explaining the in expression + in undefined :: String diff --git a/data/Test126.hs b/data/Test126.hs new file mode 100644 --- /dev/null +++ b/data/Test126.hs @@ -0,0 +1,3 @@ +testMethod foo bar baz qux = + -- some comment explaining the in expression + let x = undefined :: String in undefined :: String diff --git a/data/Test127.hs b/data/Test127.hs new file mode 100644 --- /dev/null +++ b/data/Test127.hs @@ -0,0 +1,6 @@ +foo foo bar baz qux = + let a = 1 + b = 2 + c = 3 + -- some comment explaining the in expression + in undefined :: String diff --git a/data/Test128.hs b/data/Test128.hs new file mode 100644 --- /dev/null +++ b/data/Test128.hs @@ -0,0 +1,6 @@ +func = + foo + $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + ] + ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] diff --git a/data/Test129.hs b/data/Test129.hs new file mode 100644 --- /dev/null +++ b/data/Test129.hs @@ -0,0 +1,1 @@ +module Main where diff --git a/data/Test13.hs b/data/Test13.hs new file mode 100644 --- /dev/null +++ b/data/Test13.hs @@ -0,0 +1,5 @@ +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test130.hs b/data/Test130.hs new file mode 100644 --- /dev/null +++ b/data/Test130.hs @@ -0,0 +1,1 @@ +module Main () where diff --git a/data/Test131.hs b/data/Test131.hs new file mode 100644 --- /dev/null +++ b/data/Test131.hs @@ -0,0 +1,1 @@ +module Main (main) where diff --git a/data/Test132.hs b/data/Test132.hs new file mode 100644 --- /dev/null +++ b/data/Test132.hs @@ -0,0 +1,1 @@ +module Main (main, test1, test2) where diff --git a/data/Test133.hs b/data/Test133.hs new file mode 100644 --- /dev/null +++ b/data/Test133.hs @@ -0,0 +1,12 @@ +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) where diff --git a/data/Test134.hs b/data/Test134.hs new file mode 100644 --- /dev/null +++ b/data/Test134.hs @@ -0,0 +1,12 @@ +module Main + ( main + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) where diff --git a/data/Test135.hs b/data/Test135.hs new file mode 100644 --- /dev/null +++ b/data/Test135.hs @@ -0,0 +1,1 @@ +module Main (Test(..)) where diff --git a/data/Test136.hs b/data/Test136.hs new file mode 100644 --- /dev/null +++ b/data/Test136.hs @@ -0,0 +1,1 @@ +module Main (module Main) where diff --git a/data/Test137.hs b/data/Test137.hs new file mode 100644 --- /dev/null +++ b/data/Test137.hs @@ -0,0 +1,1 @@ +module Main (Test(Test, a, b)) where diff --git a/data/Test138.hs b/data/Test138.hs new file mode 100644 --- /dev/null +++ b/data/Test138.hs @@ -0,0 +1,6 @@ +-- comment1 +module Main + ( Test(Test, a, b) + , foo -- comment2 + ) -- comment3 + where diff --git a/data/Test139.hs b/data/Test139.hs new file mode 100644 --- /dev/null +++ b/data/Test139.hs @@ -0,0 +1,1 @@ +module Main (Test()) where diff --git a/data/Test14.hs b/data/Test14.hs new file mode 100644 --- /dev/null +++ b/data/Test14.hs @@ -0,0 +1,1 @@ +func :: asd -> Either a b diff --git a/data/Test140.hs b/data/Test140.hs new file mode 100644 --- /dev/null +++ b/data/Test140.hs @@ -0,0 +1,1 @@ +-- Intentionally left empty diff --git a/data/Test141.hs b/data/Test141.hs new file mode 100644 --- /dev/null +++ b/data/Test141.hs @@ -0,0 +1,1 @@ +import Data.List diff --git a/data/Test142.hs b/data/Test142.hs new file mode 100644 --- /dev/null +++ b/data/Test142.hs @@ -0,0 +1,1 @@ +import Data.List as L diff --git a/data/Test143.hs b/data/Test143.hs new file mode 100644 --- /dev/null +++ b/data/Test143.hs @@ -0,0 +1,1 @@ +import qualified Data.List diff --git a/data/Test144.hs b/data/Test144.hs new file mode 100644 --- /dev/null +++ b/data/Test144.hs @@ -0,0 +1,1 @@ +import qualified Data.List as L diff --git a/data/Test145.hs b/data/Test145.hs new file mode 100644 --- /dev/null +++ b/data/Test145.hs @@ -0,0 +1,1 @@ +import safe Data.List as L diff --git a/data/Test146.hs b/data/Test146.hs new file mode 100644 --- /dev/null +++ b/data/Test146.hs @@ -0,0 +1,1 @@ +import {-# SOURCE #-} Data.List ( ) diff --git a/data/Test147.hs b/data/Test147.hs new file mode 100644 --- /dev/null +++ b/data/Test147.hs @@ -0,0 +1,1 @@ +import safe qualified Data.List diff --git a/data/Test148.hs b/data/Test148.hs new file mode 100644 --- /dev/null +++ b/data/Test148.hs @@ -0,0 +1,1 @@ +import {-# SOURCE #-} safe qualified Data.List diff --git a/data/Test149.hs b/data/Test149.hs new file mode 100644 --- /dev/null +++ b/data/Test149.hs @@ -0,0 +1,1 @@ +import qualified "base" Data.List diff --git a/data/Test15.hs b/data/Test15.hs new file mode 100644 --- /dev/null +++ b/data/Test15.hs @@ -0,0 +1,5 @@ +func + :: asd + -> Either + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test150.hs b/data/Test150.hs new file mode 100644 --- /dev/null +++ b/data/Test150.hs @@ -0,0 +1,3 @@ +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List ( ) +import {-# SOURCE #-} safe qualified Data.List hiding ( ) diff --git a/data/Test151.hs b/data/Test151.hs new file mode 100644 --- /dev/null +++ b/data/Test151.hs @@ -0,0 +1,1 @@ +import qualified Data.List ( ) diff --git a/data/Test152.hs b/data/Test152.hs new file mode 100644 --- /dev/null +++ b/data/Test152.hs @@ -0,0 +1,1 @@ +import Data.List ( nub ) diff --git a/data/Test153.hs b/data/Test153.hs new file mode 100644 --- /dev/null +++ b/data/Test153.hs @@ -0,0 +1,4 @@ +import Data.List ( foldl' + , indexElem + , nub + ) diff --git a/data/Test154.hs b/data/Test154.hs new file mode 100644 --- /dev/null +++ b/data/Test154.hs @@ -0,0 +1,14 @@ +import Test ( Long + , anymore + , fit + , items + , line + , list + , not + , onA + , quite + , single + , that + , will + , with + ) diff --git a/data/Test155.hs b/data/Test155.hs new file mode 100644 --- /dev/null +++ b/data/Test155.hs @@ -0,0 +1,11 @@ +import Test ( (+) + , (:!)(..) + , (:*)((:.), T7, t7) + , (:.) + , T + , T2() + , T3(..) + , T4(T4) + , T5(T5, t5) + , T6((<|>)) + ) diff --git a/data/Test156.hs b/data/Test156.hs new file mode 100644 --- /dev/null +++ b/data/Test156.hs @@ -0,0 +1,3 @@ +import Test hiding ( ) +import Test as T + hiding ( ) diff --git a/data/Test157.hs b/data/Test157.hs new file mode 100644 --- /dev/null +++ b/data/Test157.hs @@ -0,0 +1,13 @@ +import Prelude as X + hiding ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) diff --git a/data/Test158.hs b/data/Test158.hs new file mode 100644 --- /dev/null +++ b/data/Test158.hs @@ -0,0 +1,3 @@ +import TestJustAbitToLongModuleNameLikeThisOneIs + ( ) +import TestJustShortEnoughModuleNameLikeThisOne ( ) diff --git a/data/Test159.hs b/data/Test159.hs new file mode 100644 --- /dev/null +++ b/data/Test159.hs @@ -0,0 +1,3 @@ +import TestJustAbitToLongModuleNameLikeThisOneI + as T +import TestJustShortEnoughModuleNameLikeThisOn as T diff --git a/data/Test16.hs b/data/Test16.hs new file mode 100644 --- /dev/null +++ b/data/Test16.hs @@ -0,0 +1,6 @@ +func + :: asd + -> Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test160.hs b/data/Test160.hs new file mode 100644 --- /dev/null +++ b/data/Test160.hs @@ -0,0 +1,3 @@ +import TestJustAbitToLongModuleNameLikeTh + hiding ( ) +import TestJustShortEnoughModuleNameLike hiding ( ) diff --git a/data/Test161.hs b/data/Test161.hs new file mode 100644 --- /dev/null +++ b/data/Test161.hs @@ -0,0 +1,10 @@ +import MoreThanSufficientlyLongModuleNameWithSome + ( compact + , fit + , inA + , items + , layout + , not + , that + , will + ) diff --git a/data/Test162.hs b/data/Test162.hs new file mode 100644 --- /dev/null +++ b/data/Test162.hs @@ -0,0 +1,11 @@ +import TestJustAbitToLongModuleNameLikeTh + hiding ( abc + , def + , ghci + , jklm + ) +import TestJustShortEnoughModuleNameLike hiding ( abc + , def + , ghci + , jklm + ) diff --git a/data/Test163.hs b/data/Test163.hs new file mode 100644 --- /dev/null +++ b/data/Test163.hs @@ -0,0 +1,9 @@ +import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" A + hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff + as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe + ( ) diff --git a/data/Test164.hs b/data/Test164.hs new file mode 100644 --- /dev/null +++ b/data/Test164.hs @@ -0,0 +1,7 @@ +-- Test +import Data.List ( nub ) -- Test +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} +-- Test +import Test ( test ) diff --git a/data/Test165.hs b/data/Test165.hs new file mode 100644 --- /dev/null +++ b/data/Test165.hs @@ -0,0 +1,4 @@ +import Test ( abc + , def + -- comment + ) diff --git a/data/Test166.hs b/data/Test166.hs new file mode 100644 --- /dev/null +++ b/data/Test166.hs @@ -0,0 +1,3 @@ +import Test ( abc + -- comment + ) diff --git a/data/Test167.hs b/data/Test167.hs new file mode 100644 --- /dev/null +++ b/data/Test167.hs @@ -0,0 +1,8 @@ +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) diff --git a/data/Test168.hs b/data/Test168.hs new file mode 100644 --- /dev/null +++ b/data/Test168.hs @@ -0,0 +1,2 @@ +import Test ( -- comment + ) diff --git a/data/Test169.hs b/data/Test169.hs new file mode 100644 --- /dev/null +++ b/data/Test169.hs @@ -0,0 +1,8 @@ +import Test ( longbindingNameThatoverflowsColum + ) +import Test ( Long + ( List + , Of + , Things + ) + ) diff --git a/data/Test17.hs b/data/Test17.hs new file mode 100644 --- /dev/null +++ b/data/Test17.hs @@ -0,0 +1,6 @@ +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test170.hs b/data/Test170.hs new file mode 100644 --- /dev/null +++ b/data/Test170.hs @@ -0,0 +1,18 @@ +import Test ( Thing + ( -- Comments + ) + ) +import Test ( Thing + ( Item + -- and Comment + ) + ) +import Test ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) + ) diff --git a/data/Test171.hs b/data/Test171.hs new file mode 100644 --- /dev/null +++ b/data/Test171.hs @@ -0,0 +1,2 @@ +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + ( ) diff --git a/data/Test172.hs b/data/Test172.hs new file mode 100644 --- /dev/null +++ b/data/Test172.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE BangPatterns #-} +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + -- Test 10 + ) where +-- Test +import Data.List ( nub ) -- Test +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} +-- Test +import Test ( test ) diff --git a/data/Test173.hs b/data/Test173.hs new file mode 100644 --- /dev/null +++ b/data/Test173.hs @@ -0,0 +1,2 @@ +import Aaa +import Baa diff --git a/data/Test174.hs b/data/Test174.hs new file mode 100644 --- /dev/null +++ b/data/Test174.hs @@ -0,0 +1,5 @@ +import Zaa +import Zab + +import Aaa +import Baa diff --git a/data/Test175.hs b/data/Test175.hs new file mode 100644 --- /dev/null +++ b/data/Test175.hs @@ -0,0 +1,2 @@ +import Boo +import qualified Zoo diff --git a/data/Test176.hs b/data/Test176.hs new file mode 100644 --- /dev/null +++ b/data/Test176.hs @@ -0,0 +1,3 @@ +import Boo ( a ) + +import Boo ( b ) diff --git a/data/Test177.hs b/data/Test177.hs new file mode 100644 --- /dev/null +++ b/data/Test177.hs @@ -0,0 +1,2 @@ +import A.B.C +import A.B.D diff --git a/data/Test178.hs b/data/Test178.hs new file mode 100644 --- /dev/null +++ b/data/Test178.hs @@ -0,0 +1,1 @@ +type MySynonym = String diff --git a/data/Test179.hs b/data/Test179.hs new file mode 100644 --- /dev/null +++ b/data/Test179.hs @@ -0,0 +1,1 @@ +type MySynonym a = [a] diff --git a/data/Test18.hs b/data/Test18.hs new file mode 100644 --- /dev/null +++ b/data/Test18.hs @@ -0,0 +1,5 @@ +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) diff --git a/data/Test180.hs b/data/Test180.hs new file mode 100644 --- /dev/null +++ b/data/Test180.hs @@ -0,0 +1,3 @@ +-- | Important comment thrown in +type MySynonym b a + = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b diff --git a/data/Test181.hs b/data/Test181.hs new file mode 100644 --- /dev/null +++ b/data/Test181.hs @@ -0,0 +1,7 @@ +type MySynonym3 b a + = MySynonym a b + -> MySynonym a b + -- ^ RandomComment + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a diff --git a/data/Test182.hs b/data/Test182.hs new file mode 100644 --- /dev/null +++ b/data/Test182.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE StarIsType #-} +type MySynonym (a :: * -> *) + = MySynonym a b + -> MySynonym a b + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a diff --git a/data/Test183.hs b/data/Test183.hs new file mode 100644 --- /dev/null +++ b/data/Test183.hs @@ -0,0 +1,1 @@ +type MySynonym a = Num a => a -> Int diff --git a/data/Test184.hs b/data/Test184.hs new file mode 100644 --- /dev/null +++ b/data/Test184.hs @@ -0,0 +1,5 @@ +type MySynonym a + = Num a + => AReallyLongTypeName + -> AnotherReallyLongTypeName + -> AThirdTypeNameToOverflow diff --git a/data/Test185.hs b/data/Test185.hs new file mode 100644 --- /dev/null +++ b/data/Test185.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RankNTypes #-} +type MySynonym = forall a . [a] diff --git a/data/Test186.hs b/data/Test186.hs new file mode 100644 --- /dev/null +++ b/data/Test186.hs @@ -0,0 +1,1 @@ +type (:+:) a b = (a, b) diff --git a/data/Test187.hs b/data/Test187.hs new file mode 100644 --- /dev/null +++ b/data/Test187.hs @@ -0,0 +1,1 @@ +type a `MySynonym` b = a -> b diff --git a/data/Test188.hs b/data/Test188.hs new file mode 100644 --- /dev/null +++ b/data/Test188.hs @@ -0,0 +1,1 @@ +type a :+: b = (a, b) diff --git a/data/Test189.hs b/data/Test189.hs new file mode 100644 --- /dev/null +++ b/data/Test189.hs @@ -0,0 +1,1 @@ +type (a `Foo` b) c = (a, b, c) diff --git a/data/Test19.hs b/data/Test19.hs new file mode 100644 --- /dev/null +++ b/data/Test19.hs @@ -0,0 +1,7 @@ +func + :: Trither + asd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test190.hs b/data/Test190.hs new file mode 100644 --- /dev/null +++ b/data/Test190.hs @@ -0,0 +1,3 @@ +type Foo a -- fancy type comment + = -- strange comment + Int diff --git a/data/Test191.hs b/data/Test191.hs new file mode 100644 --- /dev/null +++ b/data/Test191.hs @@ -0,0 +1,1 @@ +type (a :+: b) = (a, b) diff --git a/data/Test192.hs b/data/Test192.hs new file mode 100644 --- /dev/null +++ b/data/Test192.hs @@ -0,0 +1,6 @@ +type Foo + = ( -- t1 + A -- t2 + , -- t3 + B -- t4 + ) -- t5 diff --git a/data/Test193.hs b/data/Test193.hs new file mode 100644 --- /dev/null +++ b/data/Test193.hs @@ -0,0 +1,2 @@ +instance MyClass Int where + myMethod x = x + 1 diff --git a/data/Test194.hs b/data/Test194.hs new file mode 100644 --- /dev/null +++ b/data/Test194.hs @@ -0,0 +1,4 @@ +instance MyClass Int where + myMethod x = + -- insightful comment + x + 1 diff --git a/data/Test195.hs b/data/Test195.hs new file mode 100644 --- /dev/null +++ b/data/Test195.hs @@ -0,0 +1,3 @@ +instance MyClass Int where + myMethod :: Int -> Int + myMethod x = x + 1 diff --git a/data/Test196.hs b/data/Test196.hs new file mode 100644 --- /dev/null +++ b/data/Test196.hs @@ -0,0 +1,9 @@ +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 diff --git a/data/Test197.hs b/data/Test197.hs new file mode 100644 --- /dev/null +++ b/data/Test197.hs @@ -0,0 +1,3 @@ +instance MyClass Int where + myMethod x = x + 1 + myMethod2 x = x + 1 diff --git a/data/Test198.hs b/data/Test198.hs new file mode 100644 --- /dev/null +++ b/data/Test198.hs @@ -0,0 +1,11 @@ +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + myMethod2 :: Int -> Int + myMethod2 x = x + 1 diff --git a/data/Test199.hs b/data/Test199.hs new file mode 100644 --- /dev/null +++ b/data/Test199.hs @@ -0,0 +1,4 @@ +-- | This instance should be commented on +instance MyClass Int where + -- | This method is also comment-worthy + myMethod x = x + 1 diff --git a/data/Test2.hs b/data/Test2.hs new file mode 100644 --- /dev/null +++ b/data/Test2.hs @@ -0,0 +1,3 @@ +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test20.hs b/data/Test20.hs new file mode 100644 --- /dev/null +++ b/data/Test20.hs @@ -0,0 +1,7 @@ +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test200.hs b/data/Test200.hs new file mode 100644 --- /dev/null +++ b/data/Test200.hs @@ -0,0 +1,4 @@ +instance MyClass Int where + type MyType = Int + myMethod :: MyType -> Int + myMethod x = x + 1 diff --git a/data/Test201.hs b/data/Test201.hs new file mode 100644 --- /dev/null +++ b/data/Test201.hs @@ -0,0 +1,5 @@ +instance MyClass Int where + type MyType = String + myMethod :: MyType -> Int + myMethod x = x + 1 + type MyType = Int diff --git a/data/Test202.hs b/data/Test202.hs new file mode 100644 --- /dev/null +++ b/data/Test202.hs @@ -0,0 +1,8 @@ +instance MyClass Int where + -- | This data is very important + data MyData = IntData + { intData :: String + , intData2 :: Int + } + myMethod :: MyData -> Int + myMethod = intData2 diff --git a/data/Test203.hs b/data/Test203.hs new file mode 100644 --- /dev/null +++ b/data/Test203.hs @@ -0,0 +1,11 @@ +instance MyClass Int where + -- | This data is important + data MyData = Test Int Int + myMethod :: MyData -> Int + myMethod = intData2 + -- | This data is also important + data MyData2 = IntData + { intData :: String + -- ^ Interesting field + , intData2 :: Int + } diff --git a/data/Test204.hs b/data/Test204.hs new file mode 100644 --- /dev/null +++ b/data/Test204.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module Lib where +instance Foo () where + newtype Bar () = Baz () + deriving (Eq, Ord, Show) + bar = Baz diff --git a/data/Test205.hs b/data/Test205.hs new file mode 100644 --- /dev/null +++ b/data/Test205.hs @@ -0,0 +1,4 @@ +instance Foo Int where + newtype Bar Int = BarInt + { unBarInt :: Int + } diff --git a/data/Test206.hs b/data/Test206.hs new file mode 100644 --- /dev/null +++ b/data/Test206.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +type family F a +type instance F Int = IO Int diff --git a/data/Test207.hs b/data/Test207.hs new file mode 100644 --- /dev/null +++ b/data/Test207.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +type family F a +type instance F Int = IO Int -- x diff --git a/data/Test208.hs b/data/Test208.hs new file mode 100644 --- /dev/null +++ b/data/Test208.hs @@ -0,0 +1,4 @@ +{-# language TypeFamilies #-} +module M where +type family F a +type instance F Int = IO Int diff --git a/data/Test209.hs b/data/Test209.hs new file mode 100644 --- /dev/null +++ b/data/Test209.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +newtype instance F Int = N Int diff --git a/data/Test21.hs b/data/Test21.hs new file mode 100644 --- /dev/null +++ b/data/Test21.hs @@ -0,0 +1,7 @@ +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test210.hs b/data/Test210.hs new file mode 100644 --- /dev/null +++ b/data/Test210.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +newtype instance F Int = N Int -- x diff --git a/data/Test211.hs b/data/Test211.hs new file mode 100644 --- /dev/null +++ b/data/Test211.hs @@ -0,0 +1,4 @@ +{-# language TypeFamilies #-} +module M where +data family F a +newtype instance F Int = N Int diff --git a/data/Test212.hs b/data/Test212.hs new file mode 100644 --- /dev/null +++ b/data/Test212.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +data instance F Int = D Int diff --git a/data/Test213.hs b/data/Test213.hs new file mode 100644 --- /dev/null +++ b/data/Test213.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +data instance F Int = D Int -- x diff --git a/data/Test214.hs b/data/Test214.hs new file mode 100644 --- /dev/null +++ b/data/Test214.hs @@ -0,0 +1,4 @@ +{-# language TypeFamilies #-} +module M where +data family F a +data instance F Int = D Int diff --git a/data/Test215.hs b/data/Test215.hs new file mode 100644 --- /dev/null +++ b/data/Test215.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + type family F a +instance C Int where + type F Int = IO Int diff --git a/data/Test216.hs b/data/Test216.hs new file mode 100644 --- /dev/null +++ b/data/Test216.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + type family F a +instance C Int where + type F Int = IO Int -- x diff --git a/data/Test217.hs b/data/Test217.hs new file mode 100644 --- /dev/null +++ b/data/Test217.hs @@ -0,0 +1,6 @@ +{-# language TypeFamilies #-} +module M where +class C a where + type family F a +instance C Int where + type F Int = IO Int diff --git a/data/Test218.hs b/data/Test218.hs new file mode 100644 --- /dev/null +++ b/data/Test218.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + newtype F Int = N Int diff --git a/data/Test219.hs b/data/Test219.hs new file mode 100644 --- /dev/null +++ b/data/Test219.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + newtype F Int = N Int -- x diff --git a/data/Test22.hs b/data/Test22.hs new file mode 100644 --- /dev/null +++ b/data/Test22.hs @@ -0,0 +1,7 @@ +func + :: ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test220.hs b/data/Test220.hs new file mode 100644 --- /dev/null +++ b/data/Test220.hs @@ -0,0 +1,6 @@ +{-# language TypeFamilies #-} +module M where +class C a where + data family F a +instance C Int where + newtype F Int = N Int diff --git a/data/Test221.hs b/data/Test221.hs new file mode 100644 --- /dev/null +++ b/data/Test221.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + data F Int = D Int diff --git a/data/Test222.hs b/data/Test222.hs new file mode 100644 --- /dev/null +++ b/data/Test222.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + data F Int = D Int -- x diff --git a/data/Test223.hs b/data/Test223.hs new file mode 100644 --- /dev/null +++ b/data/Test223.hs @@ -0,0 +1,6 @@ +{-# language TypeFamilies #-} +module M where +class C a where + data family F a +instance C Int where + data F Int = D Int diff --git a/data/Test224.hs b/data/Test224.hs new file mode 100644 --- /dev/null +++ b/data/Test224.hs @@ -0,0 +1,3 @@ +module Main where +import Prelude +firstDecl = True diff --git a/data/Test225.hs b/data/Test225.hs new file mode 100644 --- /dev/null +++ b/data/Test225.hs @@ -0,0 +1,10 @@ +func = do + -- complex first step + aaa + -- complex second step + bbb + where + helper :: Helper + helper = helpful + other :: Other + other = True diff --git a/data/Test226.hs b/data/Test226.hs new file mode 100644 --- /dev/null +++ b/data/Test226.hs @@ -0,0 +1,1 @@ +type instance MyFam Bool = String diff --git a/data/Test227.hs b/data/Test227.hs new file mode 100644 --- /dev/null +++ b/data/Test227.hs @@ -0,0 +1,1 @@ +type instance MyFam (Maybe a) = a -> Bool diff --git a/data/Test228.hs b/data/Test228.hs new file mode 100644 --- /dev/null +++ b/data/Test228.hs @@ -0,0 +1,4 @@ +type instance MyFam ALongishType + = AMuchLongerTypeThanThat + -> AnEvenLongerTypeThanTheLastOne + -> ShouldDefinitelyOverflow diff --git a/data/Test229.hs b/data/Test229.hs new file mode 100644 --- /dev/null +++ b/data/Test229.hs @@ -0,0 +1,3 @@ +-- | A happy family +type instance MyFam Bool -- This is an odd one + = AnotherType -- Here's another diff --git a/data/Test23.hs b/data/Test23.hs new file mode 100644 --- /dev/null +++ b/data/Test23.hs @@ -0,0 +1,1 @@ +func :: [a -> b] diff --git a/data/Test230.hs b/data/Test230.hs new file mode 100644 --- /dev/null +++ b/data/Test230.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} +func = if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test231.hs b/data/Test231.hs new file mode 100644 --- /dev/null +++ b/data/Test231.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MultiWayIf #-} +func = do + foo + bar $ if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test232.hs b/data/Test232.hs new file mode 100644 --- /dev/null +++ b/data/Test232.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LambdaCase #-} +func = \case + FooBar -> x + Baz -> y diff --git a/data/Test233.hs b/data/Test233.hs new file mode 100644 --- /dev/null +++ b/data/Test233.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ImplicitParams #-} +func :: (?asd::Int) -> () diff --git a/data/Test234.hs b/data/Test234.hs new file mode 100644 --- /dev/null +++ b/data/Test234.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ImplicitParams #-} +func + :: ( ?asd + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> () diff --git a/data/Test235.hs b/data/Test235.hs new file mode 100644 --- /dev/null +++ b/data/Test235.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RecursiveDo #-} +foo = do + rec a <- f b + b <- g a + return (a, b) diff --git a/data/Test236.hs b/data/Test236.hs new file mode 100644 --- /dev/null +++ b/data/Test236.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RecursiveDo #-} +foo = do + rec -- comment + a <- f b + b <- g a + return (a, b) diff --git a/data/Test237.hs b/data/Test237.hs new file mode 100644 --- /dev/null +++ b/data/Test237.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +module Test (type (++), (++), pattern Foo) where diff --git a/data/Test238.hs b/data/Test238.hs new file mode 100644 --- /dev/null +++ b/data/Test238.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +import Test ( type (++) + , (++) + , pattern (:.) + , pattern Foo + ) diff --git a/data/Test239.hs b/data/Test239.hs new file mode 100644 --- /dev/null +++ b/data/Test239.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern J x = Just x diff --git a/data/Test24.hs b/data/Test24.hs new file mode 100644 --- /dev/null +++ b/data/Test24.hs @@ -0,0 +1,4 @@ +func + :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ] diff --git a/data/Test240.hs b/data/Test240.hs new file mode 100644 --- /dev/null +++ b/data/Test240.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern F x <- (x, _) diff --git a/data/Test241.hs b/data/Test241.hs new file mode 100644 --- /dev/null +++ b/data/Test241.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern HeadC x <- x : xs where + HeadC x = [x] diff --git a/data/Test242.hs b/data/Test242.hs new file mode 100644 --- /dev/null +++ b/data/Test242.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern Head2 x y <- x : y : xs where + Head2 x y = [x, y] diff --git a/data/Test243.hs b/data/Test243.hs new file mode 100644 --- /dev/null +++ b/data/Test243.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern x :> y = [x, y] diff --git a/data/Test244.hs b/data/Test244.hs new file mode 100644 --- /dev/null +++ b/data/Test244.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern MyData { a, b, c } = [a, b, c] diff --git a/data/Test245.hs b/data/Test245.hs new file mode 100644 --- /dev/null +++ b/data/Test245.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = + [myLongLeftVariableName, myLongRightVariableName] diff --git a/data/Test246.hs b/data/Test246.hs new file mode 100644 --- /dev/null +++ b/data/Test246.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- + [myLongLeftVariableName, myLongRightVariableName] where + MyInfixPatternMatcher x y = [x, x, y] diff --git a/data/Test247.hs b/data/Test247.hs new file mode 100644 --- /dev/null +++ b/data/Test247.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern J :: a -> Maybe a +pattern J x = Just x diff --git a/data/Test248.hs b/data/Test248.hs new file mode 100644 --- /dev/null +++ b/data/Test248.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x diff --git a/data/Test249.hs b/data/Test249.hs new file mode 100644 --- /dev/null +++ b/data/Test249.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- + (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x diff --git a/data/Test25.hs b/data/Test25.hs new file mode 100644 --- /dev/null +++ b/data/Test25.hs @@ -0,0 +1,5 @@ +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test250.hs b/data/Test250.hs new file mode 100644 --- /dev/null +++ b/data/Test250.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x -- negative comment + Signed Zero = 0 -- zero comment + Signed (Pos x) = x -- positive comment diff --git a/data/Test251.hs b/data/Test251.hs new file mode 100644 --- /dev/null +++ b/data/Test251.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern J, K :: a -> Maybe a diff --git a/data/Test252.hs b/data/Test252.hs new file mode 100644 --- /dev/null +++ b/data/Test252.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern LongMatcher + :: longlongtypevar + -> longlongtypevar + -> longlongtypevar + -> Maybe [longlongtypevar] +pattern LongMatcher x y z = Just [x, y, z] diff --git a/data/Test253.hs b/data/Test253.hs new file mode 100644 --- /dev/null +++ b/data/Test253.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnboxedTuples #-} +spanKey :: (# Int, Int #) -> (# Int, Int #) +spanKey = case foo of + (# bar, baz #) -> (# baz, bar #) diff --git a/data/Test254.hs b/data/Test254.hs new file mode 100644 --- /dev/null +++ b/data/Test254.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) +spanKey = case foo of + (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/data/Test255.hs b/data/Test255.hs new file mode 100644 --- /dev/null +++ b/data/Test255.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe + |] diff --git a/data/Test256.hs b/data/Test256.hs new file mode 100644 --- /dev/null +++ b/data/Test256.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe|] diff --git a/data/Test257.hs b/data/Test257.hs new file mode 100644 --- /dev/null +++ b/data/Test257.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +func = do + let body = [json| + hello + |] + pure True diff --git a/data/Test258.hs b/data/Test258.hs new file mode 100644 --- /dev/null +++ b/data/Test258.hs @@ -0,0 +1,9 @@ +-- brittany { lconfig_allowHangingQuasiQuotes: False } +{-# LANGUAGE QuasiQuotes #-} +func = do + let + body = + [json| + hello + |] + pure True diff --git a/data/Test259.hs b/data/Test259.hs new file mode 100644 --- /dev/null +++ b/data/Test259.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE OverloadedLabels #-} +foo = #bar diff --git a/data/Test26.hs b/data/Test26.hs new file mode 100644 --- /dev/null +++ b/data/Test26.hs @@ -0,0 +1,1 @@ +func :: (a, b, c) diff --git a/data/Test260.hs b/data/Test260.hs new file mode 100644 --- /dev/null +++ b/data/Test260.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE OverloadedLabels #-} +foo = #bar . #baz $ fmap #foo xs diff --git a/data/Test261.hs b/data/Test261.hs new file mode 100644 --- /dev/null +++ b/data/Test261.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ImplicitParams #-} +foo = ?bar diff --git a/data/Test262.hs b/data/Test262.hs new file mode 100644 --- /dev/null +++ b/data/Test262.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ImplicitParams #-} +foo = let ?bar = Foo in value diff --git a/data/Test263.hs b/data/Test263.hs new file mode 100644 --- /dev/null +++ b/data/Test263.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE ImplicitParams #-} +foo :: (?bar::Bool) => () +foo = () diff --git a/data/Test264.hs b/data/Test264.hs new file mode 100644 --- /dev/null +++ b/data/Test264.hs @@ -0,0 +1,4 @@ +func = do + abc <- foo +--abc +return () diff --git a/data/Test265.hs b/data/Test265.hs new file mode 100644 --- /dev/null +++ b/data/Test265.hs @@ -0,0 +1,1 @@ +func = (()) diff --git a/data/Test266.hs b/data/Test266.hs new file mode 100644 --- /dev/null +++ b/data/Test266.hs @@ -0,0 +1,4 @@ +func = do + let foo True = True + foo _ = False + return () diff --git a/data/Test267.hs b/data/Test267.hs new file mode 100644 --- /dev/null +++ b/data/Test267.hs @@ -0,0 +1,3 @@ +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } diff --git a/data/Test268.hs b/data/Test268.hs new file mode 100644 --- /dev/null +++ b/data/Test268.hs @@ -0,0 +1,5 @@ +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state + , _lstate_foo = _lstate_foo state + } diff --git a/data/Test269.hs b/data/Test269.hs new file mode 100644 --- /dev/null +++ b/data/Test269.hs @@ -0,0 +1,6 @@ +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test27.hs b/data/Test27.hs new file mode 100644 --- /dev/null +++ b/data/Test27.hs @@ -0,0 +1,1 @@ +func :: ((a, b, c), (a, b, c), (a, b, c)) diff --git a/data/Test270.hs b/data/Test270.hs new file mode 100644 --- /dev/null +++ b/data/Test270.hs @@ -0,0 +1,1 @@ +func = Foo { _lstate_indent = _lstate_indent state } diff --git a/data/Test271.hs b/data/Test271.hs new file mode 100644 --- /dev/null +++ b/data/Test271.hs @@ -0,0 +1,4 @@ +func = Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_fooo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test272.hs b/data/Test272.hs new file mode 100644 --- /dev/null +++ b/data/Test272.hs @@ -0,0 +1,4 @@ +func = do + Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test273.hs b/data/Test273.hs new file mode 100644 --- /dev/null +++ b/data/Test273.hs @@ -0,0 +1,4 @@ +func = do +-- abc + -- def + return () diff --git a/data/Test274.hs b/data/Test274.hs new file mode 100644 --- /dev/null +++ b/data/Test274.hs @@ -0,0 +1,6 @@ +func = do + do + return () + -- abc + -- def + return () diff --git a/data/Test275.hs b/data/Test275.hs new file mode 100644 --- /dev/null +++ b/data/Test275.hs @@ -0,0 +1,6 @@ +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/data/Test276.hs b/data/Test276.hs new file mode 100644 --- /dev/null +++ b/data/Test276.hs @@ -0,0 +1,7 @@ +func = + ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + $ abc + $ def + $ ghi + $ jkl + ) diff --git a/data/Test277.hs b/data/Test277.hs new file mode 100644 --- /dev/null +++ b/data/Test277.hs @@ -0,0 +1,2 @@ +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where reassoc (v, e, w) = (v, (e, w)) diff --git a/data/Test278.hs b/data/Test278.hs new file mode 100644 --- /dev/null +++ b/data/Test278.hs @@ -0,0 +1,4 @@ +downloadRepoPackage = case repo of + RepoLocal {..} -> return () + RepoLocal { abc } -> return () + RepoLocal{} -> return () diff --git a/data/Test279.hs b/data/Test279.hs new file mode 100644 --- /dev/null +++ b/data/Test279.hs @@ -0,0 +1,6 @@ +func = do + let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' + (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' + -- default local dir target if there's no given target + utargets'' = "foo" + return () diff --git a/data/Test28.hs b/data/Test28.hs new file mode 100644 --- /dev/null +++ b/data/Test28.hs @@ -0,0 +1,5 @@ +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test280.hs b/data/Test280.hs new file mode 100644 --- /dev/null +++ b/data/Test280.hs @@ -0,0 +1,5 @@ +func = + [ (thing, take 10 alts) --TODO: select best ones + | (thing, _got, alts@(_ : _)) <- nosuchFooThing + , gast <- award + ] diff --git a/data/Test281.hs b/data/Test281.hs new file mode 100644 --- /dev/null +++ b/data/Test281.hs @@ -0,0 +1,5 @@ +func = if x + then if y -- y is important + then foo + else bar + else Nothing diff --git a/data/Test282.hs b/data/Test282.hs new file mode 100644 --- /dev/null +++ b/data/Test282.hs @@ -0,0 +1,7 @@ +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return $ Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR diff --git a/data/Test283.hs b/data/Test283.hs new file mode 100644 --- /dev/null +++ b/data/Test283.hs @@ -0,0 +1,6 @@ +layoutWriteNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () diff --git a/data/Test284.hs b/data/Test284.hs new file mode 100644 --- /dev/null +++ b/data/Test284.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MultiWayIf #-} +readMergePersConfig path shouldCreate conf = do + exists <- liftIO $ System.Directory.doesFileExist path + if + | exists -> do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn e + mzero + Right x -> return x + return $ fileConf Semigroup.<> conf + | shouldCreate -> do + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Option . Just . runIdentity) + staticDefaultConfig + return $ conf + | otherwise -> do + return conf diff --git a/data/Test285.hs b/data/Test285.hs new file mode 100644 --- /dev/null +++ b/data/Test285.hs @@ -0,0 +1,12 @@ +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk diff --git a/data/Test286.hs b/data/Test286.hs new file mode 100644 --- /dev/null +++ b/data/Test286.hs @@ -0,0 +1,12 @@ +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk diff --git a/data/Test287.hs b/data/Test287.hs new file mode 100644 --- /dev/null +++ b/data/Test287.hs @@ -0,0 +1,35 @@ +showPackageDetailedInfo pkginfo = + renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) + $ char '*' + $+$ something + [ entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" + sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry + "Versions installed" + installedVersions + (altText + null + (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") + ) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) + then empty + else text "Modules:" + $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ] diff --git a/data/Test288.hs b/data/Test288.hs new file mode 100644 --- /dev/null +++ b/data/Test288.hs @@ -0,0 +1,2 @@ +isValidPosition position | validX && validY = Just position + | otherwise = Nothing diff --git a/data/Test289.hs b/data/Test289.hs new file mode 100644 --- /dev/null +++ b/data/Test289.hs @@ -0,0 +1,6 @@ +foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do + (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String + -> IO Bool ) <- + ReflexHost.newExternalEvent + liftIO . forkIO . forever $ getLine >>= inputFire + ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent diff --git a/data/Test29.hs b/data/Test29.hs new file mode 100644 --- /dev/null +++ b/data/Test29.hs @@ -0,0 +1,6 @@ +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test290.hs b/data/Test290.hs new file mode 100644 --- /dev/null +++ b/data/Test290.hs @@ -0,0 +1,2 @@ +foldrDesc f z = unSwitchQueue $ \q -> + switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/data/Test291.hs b/data/Test291.hs new file mode 100644 --- /dev/null +++ b/data/Test291.hs @@ -0,0 +1,5 @@ +autocheckCases = + [ ("Never Deadlocks" , representative deadlocksNever) + , ("No Exceptions" , representative exceptionsNever) + , ("Consistent Result", alwaysSame) -- already representative + ] diff --git a/data/Test292.hs b/data/Test292.hs new file mode 100644 --- /dev/null +++ b/data/Test292.hs @@ -0,0 +1,7 @@ +autocheckCases = + [ ("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions" , representative exceptionsNever) + , ( "Consistent Result" + , alwaysSame -- already representative + ) + ] diff --git a/data/Test293.hs b/data/Test293.hs new file mode 100644 --- /dev/null +++ b/data/Test293.hs @@ -0,0 +1,5 @@ +func = + [ (abc, (1111, 1111)) + , (def, (2, 2)) + , foo -- comment + ] diff --git a/data/Test294.hs b/data/Test294.hs new file mode 100644 --- /dev/null +++ b/data/Test294.hs @@ -0,0 +1,2 @@ +foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + where g a b = b + b * a diff --git a/data/Test295.hs b/data/Test295.hs new file mode 100644 --- /dev/null +++ b/data/Test295.hs @@ -0,0 +1,1 @@ +foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo diff --git a/data/Test296.hs b/data/Test296.hs new file mode 100644 --- /dev/null +++ b/data/Test296.hs @@ -0,0 +1,5 @@ +func = do + abc <- expr + abcccccccccccccccccc <- expr + abcccccccccccccccccccccccccccccccccccccccccc <- expr + abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr diff --git a/data/Test297.hs b/data/Test297.hs new file mode 100644 --- /dev/null +++ b/data/Test297.hs @@ -0,0 +1,3 @@ +func (MyLongFoo abc def) = 1 +func (Bar a d ) = 2 +func _ = 3 diff --git a/data/Test298.hs b/data/Test298.hs new file mode 100644 --- /dev/null +++ b/data/Test298.hs @@ -0,0 +1,14 @@ +parserCompactLocation = + [ try + $ [ ParseRelAbs (Text.Read.read digits) _ _ + | digits <- many1 digit + , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe + [ case divPart of + Nothing -> Left $ Text.Read.read digits + Just ddigits -> + Right $ Text.Read.read digits % Text.Read.read ddigits + | digits <- many1 digit + , divPart <- optionMaybe (string "/" *> many1 digit) + ] + ] + ] diff --git a/data/Test299.hs b/data/Test299.hs new file mode 100644 --- /dev/null +++ b/data/Test299.hs @@ -0,0 +1,3 @@ +func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test3.hs b/data/Test3.hs new file mode 100644 --- /dev/null +++ b/data/Test3.hs @@ -0,0 +1,4 @@ +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj diff --git a/data/Test30.hs b/data/Test30.hs new file mode 100644 --- /dev/null +++ b/data/Test30.hs @@ -0,0 +1,6 @@ +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test300.hs b/data/Test300.hs new file mode 100644 --- /dev/null +++ b/data/Test300.hs @@ -0,0 +1,4 @@ +func = + fooooooooooooooooooooooooooooooooo + + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test301.hs b/data/Test301.hs new file mode 100644 --- /dev/null +++ b/data/Test301.hs @@ -0,0 +1,5 @@ +func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + [ foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + ] diff --git a/data/Test302.hs b/data/Test302.hs new file mode 100644 --- /dev/null +++ b/data/Test302.hs @@ -0,0 +1,18 @@ +parserPrim = + [ r + | r <- + [ SGPPrimFloat $ bool id (0 -) minus $ readGnok "parserPrim" + (d1 ++ d2 ++ d3 ++ d4) + | d2 <- string "." + , d3 <- many1 (oneOf "0123456789") + , _ <- string "f" + ] + <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "f" + ] + <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "i" + ] + ] diff --git a/data/Test303.hs b/data/Test303.hs new file mode 100644 --- /dev/null +++ b/data/Test303.hs @@ -0,0 +1,2 @@ +samples = (SV.unpackaaaaadat) <&> \f -> + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test304.hs b/data/Test304.hs new file mode 100644 --- /dev/null +++ b/data/Test304.hs @@ -0,0 +1,9 @@ +runBrittany tabSize text = do + let config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text diff --git a/data/Test305.hs b/data/Test305.hs new file mode 100644 --- /dev/null +++ b/data/Test305.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +runBrittany tabSize text = do + let + config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text diff --git a/data/Test306.hs b/data/Test306.hs new file mode 100644 --- /dev/null +++ b/data/Test306.hs @@ -0,0 +1,7 @@ +foo = + ( a + , -- comment1 + b + -- comment2 + , c + ) diff --git a/data/Test307.hs b/data/Test307.hs new file mode 100644 --- /dev/null +++ b/data/Test307.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE TypeApplications #-} +foo = bar @Baz diff --git a/data/Test308.hs b/data/Test308.hs new file mode 100644 --- /dev/null +++ b/data/Test308.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TypeApplications #-} +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do + docAlt + $ -- one-line solution + [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart + ] + ] + | not hasComments + , [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> [] + ] + ++ -- one-line solution + where in next line(s) + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , Data.Maybe.isJust mWhereDocs + ] + ++ -- two-line solution + where in next line(s) + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] diff --git a/data/Test309.hs b/data/Test309.hs new file mode 100644 --- /dev/null +++ b/data/Test309.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiWayIf #-} +func = do + let foo = if + | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO + -> max + (defLen - 0.2) -- TODO + (defLen * 0.8) + | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO + return True diff --git a/data/Test31.hs b/data/Test31.hs new file mode 100644 --- /dev/null +++ b/data/Test31.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test310.hs b/data/Test310.hs new file mode 100644 --- /dev/null +++ b/data/Test310.hs @@ -0,0 +1,5 @@ +foo n = case n of + 1 -> True + -1 -> False +bar n = case n of + (-2, -2) -> (-2, -2) diff --git a/data/Test311.hs b/data/Test311.hs new file mode 100644 --- /dev/null +++ b/data/Test311.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} +foo = + let a = b @1 + cccc = () + in foo diff --git a/data/Test312.hs b/data/Test312.hs new file mode 100644 --- /dev/null +++ b/data/Test312.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RecordWildCards #-} +v = A { a = 1, .. } where b = 2 diff --git a/data/Test313.hs b/data/Test313.hs new file mode 100644 --- /dev/null +++ b/data/Test313.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RecordWildCards #-} +v = A { .. } where b = 2 diff --git a/data/Test314.hs b/data/Test314.hs new file mode 100644 --- /dev/null +++ b/data/Test314.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RecordWildCards #-} +v = A { a = 1, b = 2, c = 3 } diff --git a/data/Test315.hs b/data/Test315.hs new file mode 100644 --- /dev/null +++ b/data/Test315.hs @@ -0,0 +1,1 @@ +test :: Proxy 'Int diff --git a/data/Test316.hs b/data/Test316.hs new file mode 100644 --- /dev/null +++ b/data/Test316.hs @@ -0,0 +1,1 @@ +test :: Proxy '[ 'True] diff --git a/data/Test317.hs b/data/Test317.hs new file mode 100644 --- /dev/null +++ b/data/Test317.hs @@ -0,0 +1,1 @@ +test :: Proxy '[Bool] diff --git a/data/Test318.hs b/data/Test318.hs new file mode 100644 --- /dev/null +++ b/data/Test318.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes, KindSignatures #-} +func + :: forall m str + . (Str str, Monad m) + => Int + -> Proxy (str :: [*]) + -> m (Tagged str String) diff --git a/data/Test319.hs b/data/Test319.hs new file mode 100644 --- /dev/null +++ b/data/Test319.hs @@ -0,0 +1,13 @@ +widgetsDyn = + [ [ vBox + [ padTop Max outputLinesWidget + , padRight Max wid1 <+> flowWidget -- alignment here is strange/buggy + , padBottom (Pad 5) help + ] + ] + | wid1 <- promptDyn + , (flowWidget, _) <- flowResultD + , outputLinesWidget <- outputLinesWidgetD + , help <- suggestionHelpBox + , parser <- cmdParserD + ] diff --git a/data/Test32.hs b/data/Test32.hs new file mode 100644 --- /dev/null +++ b/data/Test32.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . Foo + => ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test320.hs b/data/Test320.hs new file mode 100644 --- /dev/null +++ b/data/Test320.hs @@ -0,0 +1,2 @@ +fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b +fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) diff --git a/data/Test321.hs b/data/Test321.hs new file mode 100644 --- /dev/null +++ b/data/Test321.hs @@ -0,0 +1,1 @@ +cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] diff --git a/data/Test322.hs b/data/Test322.hs new file mode 100644 --- /dev/null +++ b/data/Test322.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE TemplateHaskell #-} +deriveFromJSON (unPrefix "assignPost") ''AssignmentPost diff --git a/data/Test323.hs b/data/Test323.hs new file mode 100644 --- /dev/null +++ b/data/Test323.hs @@ -0,0 +1,7 @@ +main = -- a + let --b + x = 1 -- x + y = 2 -- y + in do + print x + print y diff --git a/data/Test324.hs b/data/Test324.hs new file mode 100644 --- /dev/null +++ b/data/Test324.hs @@ -0,0 +1,9 @@ +alternatives :: Parser (Maybe Text) +alternatives = + alternativeOne -- first try this one + <|> alterantiveTwo -- then this one + <|> alternativeThree -- then this one + where + alternativeOne = purer "one" + alternativeTwo = purer "two" + alterantiveThree = purer "three" diff --git a/data/Test325.hs b/data/Test325.hs new file mode 100644 --- /dev/null +++ b/data/Test325.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE BangPatterns #-} +func = do + let !forced = some + pure () diff --git a/data/Test326.hs b/data/Test326.hs new file mode 100644 --- /dev/null +++ b/data/Test326.hs @@ -0,0 +1,4 @@ +spanKey p q = case minViewWithKey q of + Just ((k, _), q') | p k -> + let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') + _ -> ([], q) diff --git a/data/Test327.hs b/data/Test327.hs new file mode 100644 --- /dev/null +++ b/data/Test327.hs @@ -0,0 +1,1 @@ +a :: () ':- () diff --git a/data/Test328.hs b/data/Test328.hs new file mode 100644 --- /dev/null +++ b/data/Test328.hs @@ -0,0 +1,3 @@ +func = do + createDirectoryIfMissing True path + openFile fileName AppendMode diff --git a/data/Test329.hs b/data/Test329.hs new file mode 100644 --- /dev/null +++ b/data/Test329.hs @@ -0,0 +1,7 @@ +alternatives :: Parser (Maybe Text) +alternatives = -- a + ( -- b + alternativeOne -- c + <|> alterantiveTwo -- d + <|> alternativeThree -- e + ) -- f diff --git a/data/Test33.hs b/data/Test33.hs new file mode 100644 --- /dev/null +++ b/data/Test33.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test330.hs b/data/Test330.hs new file mode 100644 --- /dev/null +++ b/data/Test330.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall a + . () + => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +func + :: () + => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test331.hs b/data/Test331.hs new file mode 100644 --- /dev/null +++ b/data/Test331.hs @@ -0,0 +1,5 @@ +go l [] = Right l +go l ((IRType, _a) : eqr) = go l eqr +go l ((_, IRType) : eqr) = go l eqr +go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 +go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 diff --git a/data/Test332.hs b/data/Test332.hs new file mode 100644 --- /dev/null +++ b/data/Test332.hs @@ -0,0 +1,2 @@ +type instance XPure StageParse = () +type Pair a = (a, a) diff --git a/data/Test333.hs b/data/Test333.hs new file mode 100644 --- /dev/null +++ b/data/Test333.hs @@ -0,0 +1,18 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = + let + eyuAfrarIso' + :: (RveoexdxunuAafalm -> Axlau (Axlau (a, OinejrdCplle))) + -> Gbodoy + -> Axlau (Axlau OinejrdCplle, Gbodoy) + eyuAfrarIso' = ulcPaaekBst cnehokzozwbVaguvu + amkgoxEhalazJjxunecCuIfaw + :: Axlau (Axlau OinejrdCplle, Gbodoy) -> Axlau RqlnrluYqednbCiggxi + amkgoxEhalazJjxunecCuIfaw uKqviuBisjtn = do + (sEmo, quc) <- uKqviuBisjtn + pure (xoheccewfWoeyiagOkfodiq sEmo quc) + xoheccewfWoeyiagOkfodiq + :: Axlau OinejrdCplle -> Gbodoy -> RqlnrluYqednbCiggxi + xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of + Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo + in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) diff --git a/data/Test334.hs b/data/Test334.hs new file mode 100644 --- /dev/null +++ b/data/Test334.hs @@ -0,0 +1,5 @@ +spec = do + it "creates a snapshot at the given level" . withGraph runDB $ do + lift $ do + studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x + elaSnapshotReadingLevel snapshot `shouldBe` 12 diff --git a/data/Test335.hs b/data/Test335.hs new file mode 100644 --- /dev/null +++ b/data/Test335.hs @@ -0,0 +1,12 @@ +jaicyhHumzo btrKpeyiFej mava = do + m :: VtohxeRgpmgsu <- qloxIfiq mava + case m of + ZumnaoFujayerIswadabo kkecm chlixxag -> do + imomue <- ozisduRaqiseSBAob btrKpeyiFej $ \s -> + case MizA.pigevo kkecm (_tc_gulawulu s) of + Ebocaba -> + ( s { _tc_gulawulu = MizA.jxariu kkecm rwuRqxzhjo (_tc_gulawulu s) } + , Gtzvonm + ) + Xcde{} -> (s, Pioemav) + pure imomue diff --git a/data/Test336.hs b/data/Test336.hs new file mode 100644 --- /dev/null +++ b/data/Test336.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyMultiple } +foo = bar + arg1 -- this is the first argument + arg2 -- this is the second argument + arg3 -- this is the third argument, now I'll skip one comment + arg4 + arg5 -- this is the fifth argument + arg6 -- this is the sixth argument diff --git a/data/Test337.hs b/data/Test337.hs new file mode 100644 --- /dev/null +++ b/data/Test337.hs @@ -0,0 +1,4 @@ +True `nand` True = False +nand _ _ = True +nor False False = True +_ `nor` _ = False diff --git a/data/Test338.hs b/data/Test338.hs new file mode 100644 --- /dev/null +++ b/data/Test338.hs @@ -0,0 +1,1 @@ +f ((:) a as) = undefined diff --git a/data/Test339.hs b/data/Test339.hs new file mode 100644 --- /dev/null +++ b/data/Test339.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +a = \x -> x +b = \ ~x -> x +c = \ !x -> x +d = \(~x) -> x diff --git a/data/Test34.hs b/data/Test34.hs new file mode 100644 --- /dev/null +++ b/data/Test34.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RankNTypes #-} +addFlagStringParam + :: forall f out + . (Applicative f) + => String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> String -- ^ param name + -> Flag String -- ^ properties + -> CmdParser f out String diff --git a/data/Test340.hs b/data/Test340.hs new file mode 100644 --- /dev/null +++ b/data/Test340.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RankNTypes #-} +func :: forall b . Show b => b -> String diff --git a/data/Test341.hs b/data/Test341.hs new file mode 100644 --- /dev/null +++ b/data/Test341.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TypeFamilies #-} +f :: ((~) a b) => a -> b +f = id diff --git a/data/Test342.hs b/data/Test342.hs new file mode 100644 --- /dev/null +++ b/data/Test342.hs @@ -0,0 +1,50 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +vakjkeSulxudbFokvir = Duotpo + { _ekku_gcrpbze = xgonae (1 :: Int) + , _oola_louwu = FoqsiYcuidx + { _xxagu_umea_iaztoj = xgonae False + , _tuktg_tizo_kfikacygsqf = xgonae False + , _ahzbo_xpow_otq_nzeyufq = xgonae False + , _uagpi_lzps_luy_xcjn = xgonae False + , _dxono_qjef_aqtafq_bes = xgonae False + , _yzuaf_nviy_vuhwxe_ihnbo_uhw = xgonae False + , _iwcit_fzjs_yerakt_dicox_mtryitko = xgonae False + , _ehjim_ucfe_dewarp_newrt_gso = xgonae False + , _ogtxb_ivoj_amqgai_rttui_xuwhetb = xgonae False + , _bhycb_iexz_megaug_qunoa_ohaked = xgonae False + , _nnmbe_uqgt_ewsuga_vaiis = xgonae False + , _otzil_ucvugaiyj_aosoiatunx_asir = xgonae False + } + , _iwsc_lalojz = XqspaiDainqw + { _uajznac_ugah = xgonae (80 :: Int) + , _qayziku_gazibzDejipj = xgonae DewizeCxwgyiKjig + , _auhebll_fiqjxyArfxia = xgonae (2 :: Int) + , _zubfuhq_dupiwnIoophXameeet = xgonae True + , _oavnuqg_opkreyOufuIkifiin = xgonae True + , _ufojfwy_fhuzcePeqwfu = xgonae (50 :: Int) + , _mlosikq_zajdxxSeRoelpf = xgonae (50 :: Int) + , _heemavf_fjgOfoaikh = xgonae (FyoVfvdygaZuzuvbeWarwuq 3) + , _ohxmeoq_ogtbfoPtqezVseu = xgonae (EdjotoLcbapUdiuMmytwoig 0.7) + , _omupuiu_ituamexjuLccwu = xgonae (30 :: Int) + , _xoseksf_atvwwdwaoHanofMyUvujjopoz = xgonae True + , _umuuuat_nuamezwWeqfUqzrnaxwp = xgonae False + , _uuriguz_wixhutbuKecigaFiwosret = xgonae True + , _betohxp_scixaLsvcesErtwItxrnaJmuz = xgonae False + , _lchxgee_olaetGcqzuqxVujenCzexub = xgonae True + , _egeibao_imamkuigqikhZdcbpidokVcixiqew = xgonae False + } + , _nloo_cfmrgZcisiugk = YuwodSavxwnicBekuel + { _oebew_rrtpvthUzlizjAqIwesly = xgonae False + , _blkff_Acxoid = xgonae False + , _datei_YewolAowoqOpunvpgu = xgonae BeekgUzojaPnixxaruJehyPmnnfu + , _ejfrj_eheb_justvh_pumcp_ismya = xgonae False + } + , _kena_uzeddovosoki = NyoRvshullezUpauud + { _mtfuwi_TUVEmoi = xgonae RZXKoytUtogx + , _larqam_adaxPehaylZafeqgpc = xgonae False + } + , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } + , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False + , _qaqb_eykzuyuwi = xgonae False + -- test comment + } diff --git a/data/Test343.hs b/data/Test343.hs new file mode 100644 --- /dev/null +++ b/data/Test343.hs @@ -0,0 +1,10 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +vakjkeSulxudbFokvir = Duotpo + { _ekku_gcrpbze = xgonae (1 :: Int) + , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } + , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False + , _qaqb_eykzuyuwi = xgonae False + -- test comment + , -- N.B. + .. -- x + } diff --git a/data/Test344.hs b/data/Test344.hs new file mode 100644 --- /dev/null +++ b/data/Test344.hs @@ -0,0 +1,7 @@ +func = abc + def + -- a + -- b + -- comment + where + abc = 13 + def = 1 diff --git a/data/Test345.hs b/data/Test345.hs new file mode 100644 --- /dev/null +++ b/data/Test345.hs @@ -0,0 +1,13 @@ +zItazySunefp twgq nlyo lwojjoBiecao = + let mhIarjyai = + ukwAausnfcn + $ XojlsTOSR.vuwOvuvdAZUOJaa + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.popjAyijoWarueeP + $ XojlsTOSR.jpwuPmafuDqlbkt nlyo + $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng + $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow + $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) + $ etOslnoz lwojjoBiecao + in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) diff --git a/data/Test346.hs b/data/Test346.hs new file mode 100644 --- /dev/null +++ b/data/Test346.hs @@ -0,0 +1,2 @@ +-- test +module MyModule where diff --git a/data/Test347.hs b/data/Test347.hs new file mode 100644 --- /dev/null +++ b/data/Test347.hs @@ -0,0 +1,8 @@ +foo = + [ ("xxx", "xx") + , -- + ("xx" , "xx") + -- + , ("xx" , "xxxxx") + , ("xx" , "xx") + ] diff --git a/data/Test348.hs b/data/Test348.hs new file mode 100644 --- /dev/null +++ b/data/Test348.hs @@ -0,0 +1,8 @@ +foo = + [ ("xx", "xx") + , ( "xx" -- + , "xx" + ) + , ("xx", "xxxxx") + , ("xx", "xx") + ] diff --git a/data/Test349.hs b/data/Test349.hs new file mode 100644 --- /dev/null +++ b/data/Test349.hs @@ -0,0 +1,6 @@ +module Main + ( DataTypeI + , DataTypeII(DataConstructor) + -- * Haddock heading + , name + ) where diff --git a/data/Test35.hs b/data/Test35.hs new file mode 100644 --- /dev/null +++ b/data/Test35.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test350.hs b/data/Test350.hs new file mode 100644 --- /dev/null +++ b/data/Test350.hs @@ -0,0 +1,23 @@ +xeoeqibIaib + :: ( KqujhIsaus m + , XivuvIpoboi Droqifim m + , IgorvOtowtf m + , RyagaYaqac m + , QouruDU m + ) + => MaptAdfuxgu + -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd + -> QNOZqwuzg + -> Eoattuq + '[ XkatytdWdquraosu -- test comment + , KyezKijim -- another test comment + , DjmioeePuoeg + , NinrxoiOwezc + , QATAlrijacpk + , TrutvotwIwifiqOjdtu + , CoMmuatjwr + , BoZckzqyodseZole + , VagfwoXaeChfqe + ] + m + () diff --git a/data/Test351.hs b/data/Test351.hs new file mode 100644 --- /dev/null +++ b/data/Test351.hs @@ -0,0 +1,7 @@ +createRedirectedProcess processConfig = do + let redirectedProc = (_processConfig_inner processConfig) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + foo diff --git a/data/Test352.hs b/data/Test352.hs new file mode 100644 --- /dev/null +++ b/data/Test352.hs @@ -0,0 +1,5 @@ +instance HasDependencies SomeDataModel where + -- N.B. Here is a bunch of explanatory context about the relationship + -- between these data models or whatever. + type Dependencies SomeDataModel + = (SomeOtherDataModelId, SomeOtherOtherDataModelId) diff --git a/data/Test353.hs b/data/Test353.hs new file mode 100644 --- /dev/null +++ b/data/Test353.hs @@ -0,0 +1,4 @@ +func = + do + y + >>= x diff --git a/data/Test354.hs b/data/Test354.hs new file mode 100644 --- /dev/null +++ b/data/Test354.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test355.hs b/data/Test355.hs new file mode 100644 --- /dev/null +++ b/data/Test355.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo diff --git a/data/Test356.hs b/data/Test356.hs new file mode 100644 --- /dev/null +++ b/data/Test356.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_indentAmount: 8, lconfig_indentPolicy: IndentPolicyMultiple } +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo diff --git a/data/Test357.hs b/data/Test357.hs new file mode 100644 --- /dev/null +++ b/data/Test357.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +foo = asdyf8asdf + "ajsdfas" + [ asjdf asyhf $ do + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ] diff --git a/data/Test358.hs b/data/Test358.hs new file mode 100644 --- /dev/null +++ b/data/Test358.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: a -> a diff --git a/data/Test359.hs b/data/Test359.hs new file mode 100644 --- /dev/null +++ b/data/Test359.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test36.hs b/data/Test36.hs new file mode 100644 --- /dev/null +++ b/data/Test36.hs @@ -0,0 +1,1 @@ +func :: a -> b -- comment diff --git a/data/Test360.hs b/data/Test360.hs new file mode 100644 --- /dev/null +++ b/data/Test360.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj diff --git a/data/Test361.hs b/data/Test361.hs new file mode 100644 --- /dev/null +++ b/data/Test361.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: ((a)) diff --git a/data/Test362.hs b/data/Test362.hs new file mode 100644 --- /dev/null +++ b/data/Test362.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: (a -> a) -> a diff --git a/data/Test363.hs b/data/Test363.hs new file mode 100644 --- /dev/null +++ b/data/Test363.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: a -> (a -> a) diff --git a/data/Test364.hs b/data/Test364.hs new file mode 100644 --- /dev/null +++ b/data/Test364.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: (((((((((()))))))))) +-- current output is.. funny. wonder if that can/needs to be improved.. diff --git a/data/Test365.hs b/data/Test365.hs new file mode 100644 --- /dev/null +++ b/data/Test365.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: () diff --git a/data/Test366.hs b/data/Test366.hs new file mode 100644 --- /dev/null +++ b/data/Test366.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + ) diff --git a/data/Test367.hs b/data/Test367.hs new file mode 100644 --- /dev/null +++ b/data/Test367.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) diff --git a/data/Test368.hs b/data/Test368.hs new file mode 100644 --- /dev/null +++ b/data/Test368.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) + -> lakjsdlkjasldkj diff --git a/data/Test369.hs b/data/Test369.hs new file mode 100644 --- /dev/null +++ b/data/Test369.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> lakjsdlkjasldkj diff --git a/data/Test37.hs b/data/Test37.hs new file mode 100644 --- /dev/null +++ b/data/Test37.hs @@ -0,0 +1,2 @@ +funcA :: a -> b -- comment A +funcB :: a -> b -- comment B diff --git a/data/Test370.hs b/data/Test370.hs new file mode 100644 --- /dev/null +++ b/data/Test370.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test371.hs b/data/Test371.hs new file mode 100644 --- /dev/null +++ b/data/Test371.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: asd -> Either a b diff --git a/data/Test372.hs b/data/Test372.hs new file mode 100644 --- /dev/null +++ b/data/Test372.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> Either + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test373.hs b/data/Test373.hs new file mode 100644 --- /dev/null +++ b/data/Test373.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test374.hs b/data/Test374.hs new file mode 100644 --- /dev/null +++ b/data/Test374.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test375.hs b/data/Test375.hs new file mode 100644 --- /dev/null +++ b/data/Test375.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) diff --git a/data/Test376.hs b/data/Test376.hs new file mode 100644 --- /dev/null +++ b/data/Test376.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: Trither + asd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test377.hs b/data/Test377.hs new file mode 100644 --- /dev/null +++ b/data/Test377.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test378.hs b/data/Test378.hs new file mode 100644 --- /dev/null +++ b/data/Test378.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test379.hs b/data/Test379.hs new file mode 100644 --- /dev/null +++ b/data/Test379.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test38.hs b/data/Test38.hs new file mode 100644 --- /dev/null +++ b/data/Test38.hs @@ -0,0 +1,11 @@ +-- a +func -- b + :: -- c + a -- d + -> -- e + ( -- f + c -- g + , -- h + d -- i + ) -- j +-- k diff --git a/data/Test380.hs b/data/Test380.hs new file mode 100644 --- /dev/null +++ b/data/Test380.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: [a -> b] diff --git a/data/Test381.hs b/data/Test381.hs new file mode 100644 --- /dev/null +++ b/data/Test381.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ] diff --git a/data/Test382.hs b/data/Test382.hs new file mode 100644 --- /dev/null +++ b/data/Test382.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test383.hs b/data/Test383.hs new file mode 100644 --- /dev/null +++ b/data/Test383.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: (a, b, c) diff --git a/data/Test384.hs b/data/Test384.hs new file mode 100644 --- /dev/null +++ b/data/Test384.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: ((a, b, c), (a, b, c), (a, b, c)) diff --git a/data/Test385.hs b/data/Test385.hs new file mode 100644 --- /dev/null +++ b/data/Test385.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test386.hs b/data/Test386.hs new file mode 100644 --- /dev/null +++ b/data/Test386.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test387.hs b/data/Test387.hs new file mode 100644 --- /dev/null +++ b/data/Test387.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test388.hs b/data/Test388.hs new file mode 100644 --- /dev/null +++ b/data/Test388.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test389.hs b/data/Test389.hs new file mode 100644 --- /dev/null +++ b/data/Test389.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . Foo + => ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test39.hs b/data/Test39.hs new file mode 100644 --- /dev/null +++ b/data/Test39.hs @@ -0,0 +1,4 @@ +func = f + where + {-# INLINE f #-} + f = id diff --git a/data/Test390.hs b/data/Test390.hs new file mode 100644 --- /dev/null +++ b/data/Test390.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test391.hs b/data/Test391.hs new file mode 100644 --- /dev/null +++ b/data/Test391.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test392.hs b/data/Test392.hs new file mode 100644 --- /dev/null +++ b/data/Test392.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: a -> b -- comment diff --git a/data/Test393.hs b/data/Test393.hs new file mode 100644 --- /dev/null +++ b/data/Test393.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +funcA :: a -> b -- comment A +funcB :: a -> b -- comment B diff --git a/data/Test394.hs b/data/Test394.hs new file mode 100644 --- /dev/null +++ b/data/Test394.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- a +func -- b + :: -- c + a -- d + -> -- e + ( -- f + c -- g + , -- h + d -- i + ) -- j-- k diff --git a/data/Test395.hs b/data/Test395.hs new file mode 100644 --- /dev/null +++ b/data/Test395.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ImplicitParams #-} +func :: (?asd::Int) -> () diff --git a/data/Test396.hs b/data/Test396.hs new file mode 100644 --- /dev/null +++ b/data/Test396.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ImplicitParams #-} +func + :: ( ?asd + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> () diff --git a/data/Test397.hs b/data/Test397.hs new file mode 100644 --- /dev/null +++ b/data/Test397.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = f + where + {-# INLINE f #-} + f = id diff --git a/data/Test398.hs b/data/Test398.hs new file mode 100644 --- /dev/null +++ b/data/Test398.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = ($) + where + {-# INLINE ($) #-} + ($) = id diff --git a/data/Test399.hs b/data/Test399.hs new file mode 100644 --- /dev/null +++ b/data/Test399.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = f + where + {-# INLINE CONLIKE [1] f #-} + f = id diff --git a/data/Test4.hs b/data/Test4.hs new file mode 100644 --- /dev/null +++ b/data/Test4.hs @@ -0,0 +1,1 @@ +func :: ((a)) diff --git a/data/Test40.hs b/data/Test40.hs new file mode 100644 --- /dev/null +++ b/data/Test40.hs @@ -0,0 +1,4 @@ +func = ($) + where + {-# INLINE ($) #-} + ($) = id diff --git a/data/Test400.hs b/data/Test400.hs new file mode 100644 --- /dev/null +++ b/data/Test400.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = f + where + {-# INLINE [~1] f #-} + f = id diff --git a/data/Test401.hs b/data/Test401.hs new file mode 100644 --- /dev/null +++ b/data/Test401.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + } diff --git a/data/Test402.hs b/data/Test402.hs new file mode 100644 --- /dev/null +++ b/data/Test402.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo, bar :: Baz + } diff --git a/data/Test403.hs b/data/Test403.hs new file mode 100644 --- /dev/null +++ b/data/Test403.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } diff --git a/data/Test404.hs b/data/Test404.hs new file mode 100644 --- /dev/null +++ b/data/Test404.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } diff --git a/data/Test405.hs b/data/Test405.hs new file mode 100644 --- /dev/null +++ b/data/Test405.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving Show diff --git a/data/Test406.hs b/data/Test406.hs new file mode 100644 --- /dev/null +++ b/data/Test406.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test407.hs b/data/Test407.hs new file mode 100644 --- /dev/null +++ b/data/Test407.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x = x diff --git a/data/Test408.hs b/data/Test408.hs new file mode 100644 --- /dev/null +++ b/data/Test408.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +x *** y = x diff --git a/data/Test409.hs b/data/Test409.hs new file mode 100644 --- /dev/null +++ b/data/Test409.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +(***) x y = x diff --git a/data/Test41.hs b/data/Test41.hs new file mode 100644 --- /dev/null +++ b/data/Test41.hs @@ -0,0 +1,4 @@ +func = f + where + {-# INLINE CONLIKE [1] f #-} + f = id diff --git a/data/Test410.hs b/data/Test410.hs new file mode 100644 --- /dev/null +++ b/data/Test410.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func _ = x diff --git a/data/Test411.hs b/data/Test411.hs new file mode 100644 --- /dev/null +++ b/data/Test411.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = + x diff --git a/data/Test412.hs b/data/Test412.hs new file mode 100644 --- /dev/null +++ b/data/Test412.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x diff --git a/data/Test413.hs b/data/Test413.hs new file mode 100644 --- /dev/null +++ b/data/Test413.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b + = x diff --git a/data/Test414.hs b/data/Test414.hs new file mode 100644 --- /dev/null +++ b/data/Test414.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (A a) = a diff --git a/data/Test415.hs b/data/Test415.hs new file mode 100644 --- /dev/null +++ b/data/Test415.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (x : xr) = x diff --git a/data/Test416.hs b/data/Test416.hs new file mode 100644 --- /dev/null +++ b/data/Test416.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (x :+: xr) = x diff --git a/data/Test417.hs b/data/Test417.hs new file mode 100644 --- /dev/null +++ b/data/Test417.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func | True = x diff --git a/data/Test418.hs b/data/Test418.hs new file mode 100644 --- /dev/null +++ b/data/Test418.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | x = simple expression + | otherwise = 0 diff --git a/data/Test419.hs b/data/Test419.hs new file mode 100644 --- /dev/null +++ b/data/Test419.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | a somewhat longer guard x = "and a somewhat longer expession that does not" + | otherwise = "fit without putting the guards in new lines" diff --git a/data/Test42.hs b/data/Test42.hs new file mode 100644 --- /dev/null +++ b/data/Test42.hs @@ -0,0 +1,2 @@ +{-# NOINLINE func #-} +func :: Int diff --git a/data/Test420.hs b/data/Test420.hs new file mode 100644 --- /dev/null +++ b/data/Test420.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | very long guard, another rather long guard that refers to x = nontrivial + expression + foo + bar + alsdkjlasdjlasj + | otherwise = 0 diff --git a/data/Test421.hs b/data/Test421.hs new file mode 100644 --- /dev/null +++ b/data/Test421.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | very long guard, another rather long guard that refers to x + = nontrivialexpression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test422.hs b/data/Test422.hs new file mode 100644 --- /dev/null +++ b/data/Test422.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | very loooooooooooooooooooooooooooooong guard + , another rather long guard that refers to x + = nontrivial expression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test423.hs b/data/Test423.hs new file mode 100644 --- /dev/null +++ b/data/Test423.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = x +describe "infix op" $ do diff --git a/data/Test424.hs b/data/Test424.hs new file mode 100644 --- /dev/null +++ b/data/Test424.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = x + x diff --git a/data/Test425.hs b/data/Test425.hs new file mode 100644 --- /dev/null +++ b/data/Test425.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test426.hs b/data/Test426.hs new file mode 100644 --- /dev/null +++ b/data/Test426.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj diff --git a/data/Test427.hs b/data/Test427.hs new file mode 100644 --- /dev/null +++ b/data/Test427.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test428.hs b/data/Test428.hs new file mode 100644 --- /dev/null +++ b/data/Test428.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = 1 +func = "abc" +func = 1.1e5 +func = 'x' +func = 981409823458910394810928414192837123987123987123 diff --git a/data/Test429.hs b/data/Test429.hs new file mode 100644 --- /dev/null +++ b/data/Test429.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE LambdaCase #-} +func = \case + FooBar -> x + Baz -> y diff --git a/data/Test43.hs b/data/Test43.hs new file mode 100644 --- /dev/null +++ b/data/Test43.hs @@ -0,0 +1,4 @@ +func = f + where + {-# INLINE [~1] f #-} + f = id diff --git a/data/Test430.hs b/data/Test430.hs new file mode 100644 --- /dev/null +++ b/data/Test430.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = \x -> abc +describe "app" $ do diff --git a/data/Test431.hs b/data/Test431.hs new file mode 100644 --- /dev/null +++ b/data/Test431.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = klajsdas klajsdas klajsdas diff --git a/data/Test432.hs b/data/Test432.hs new file mode 100644 --- /dev/null +++ b/data/Test432.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd diff --git a/data/Test433.hs b/data/Test433.hs new file mode 100644 --- /dev/null +++ b/data/Test433.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljas + lakjsdlajsdljas + lakjsdlajsdljas diff --git a/data/Test434.hs b/data/Test434.hs new file mode 100644 --- /dev/null +++ b/data/Test434.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (1 +) diff --git a/data/Test435.hs b/data/Test435.hs new file mode 100644 --- /dev/null +++ b/data/Test435.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (+ 1) diff --git a/data/Test436.hs b/data/Test436.hs new file mode 100644 --- /dev/null +++ b/data/Test436.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (1 `abc`) diff --git a/data/Test437.hs b/data/Test437.hs new file mode 100644 --- /dev/null +++ b/data/Test437.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (`abc` 1) diff --git a/data/Test438.hs b/data/Test438.hs new file mode 100644 --- /dev/null +++ b/data/Test438.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (abc, def) diff --git a/data/Test439.hs b/data/Test439.hs new file mode 100644 --- /dev/null +++ b/data/Test439.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + ) diff --git a/data/Test44.hs b/data/Test44.hs new file mode 100644 --- /dev/null +++ b/data/Test44.hs @@ -0,0 +1,2 @@ +data Foo = Bar {} +data Biz = Baz diff --git a/data/Test440.hs b/data/Test440.hs new file mode 100644 --- /dev/null +++ b/data/Test440.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo = + let longIdentifierForShortValue = 1 + in longIdentifierForShortValue + longIdentifierForShortValue diff --git a/data/Test441.hs b/data/Test441.hs new file mode 100644 --- /dev/null +++ b/data/Test441.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + stmt + stmt diff --git a/data/Test442.hs b/data/Test442.hs new file mode 100644 --- /dev/null +++ b/data/Test442.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + x <- stmt + stmt x diff --git a/data/Test443.hs b/data/Test443.hs new file mode 100644 --- /dev/null +++ b/data/Test443.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let x = 13 + stmt x diff --git a/data/Test444.hs b/data/Test444.hs new file mode 100644 --- /dev/null +++ b/data/Test444.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + foooooo + $ [ case + foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + of + _ -> True + ] diff --git a/data/Test445.hs b/data/Test445.hs new file mode 100644 --- /dev/null +++ b/data/Test445.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +func = if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test446.hs b/data/Test446.hs new file mode 100644 --- /dev/null +++ b/data/Test446.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +func = do + foo + bar $ if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test447.hs b/data/Test447.hs new file mode 100644 --- /dev/null +++ b/data/Test447.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + foo + $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + ] + ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] diff --git a/data/Test448.hs b/data/Test448.hs new file mode 100644 --- /dev/null +++ b/data/Test448.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main where diff --git a/data/Test449.hs b/data/Test449.hs new file mode 100644 --- /dev/null +++ b/data/Test449.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main () where diff --git a/data/Test45.hs b/data/Test45.hs new file mode 100644 --- /dev/null +++ b/data/Test45.hs @@ -0,0 +1,3 @@ +data Foo = Bar + { foo :: Baz + } diff --git a/data/Test450.hs b/data/Test450.hs new file mode 100644 --- /dev/null +++ b/data/Test450.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (main) where diff --git a/data/Test451.hs b/data/Test451.hs new file mode 100644 --- /dev/null +++ b/data/Test451.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (main, test1, test2) where diff --git a/data/Test452.hs b/data/Test452.hs new file mode 100644 --- /dev/null +++ b/data/Test452.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) where diff --git a/data/Test453.hs b/data/Test453.hs new file mode 100644 --- /dev/null +++ b/data/Test453.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main + ( main + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) where diff --git a/data/Test454.hs b/data/Test454.hs new file mode 100644 --- /dev/null +++ b/data/Test454.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (Test(..)) where diff --git a/data/Test455.hs b/data/Test455.hs new file mode 100644 --- /dev/null +++ b/data/Test455.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (module Main) where diff --git a/data/Test456.hs b/data/Test456.hs new file mode 100644 --- /dev/null +++ b/data/Test456.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (Test(Test, a, b)) where diff --git a/data/Test457.hs b/data/Test457.hs new file mode 100644 --- /dev/null +++ b/data/Test457.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (Test()) where diff --git a/data/Test458.hs b/data/Test458.hs new file mode 100644 --- /dev/null +++ b/data/Test458.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- Intentionally left empty diff --git a/data/Test459.hs b/data/Test459.hs new file mode 100644 --- /dev/null +++ b/data/Test459.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List diff --git a/data/Test46.hs b/data/Test46.hs new file mode 100644 --- /dev/null +++ b/data/Test46.hs @@ -0,0 +1,3 @@ +data Foo = Bar + { foo, bar :: Baz + } diff --git a/data/Test460.hs b/data/Test460.hs new file mode 100644 --- /dev/null +++ b/data/Test460.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List as L diff --git a/data/Test461.hs b/data/Test461.hs new file mode 100644 --- /dev/null +++ b/data/Test461.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified Data.List diff --git a/data/Test462.hs b/data/Test462.hs new file mode 100644 --- /dev/null +++ b/data/Test462.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified Data.List as L diff --git a/data/Test463.hs b/data/Test463.hs new file mode 100644 --- /dev/null +++ b/data/Test463.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import safe Data.List as L diff --git a/data/Test464.hs b/data/Test464.hs new file mode 100644 --- /dev/null +++ b/data/Test464.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import {-# SOURCE #-} Data.List () diff --git a/data/Test465.hs b/data/Test465.hs new file mode 100644 --- /dev/null +++ b/data/Test465.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import safe qualified Data.List hiding (nub) diff --git a/data/Test466.hs b/data/Test466.hs new file mode 100644 --- /dev/null +++ b/data/Test466.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import {-# SOURCE #-} safe qualified Data.List diff --git a/data/Test467.hs b/data/Test467.hs new file mode 100644 --- /dev/null +++ b/data/Test467.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified "base" Data.List diff --git a/data/Test468.hs b/data/Test468.hs new file mode 100644 --- /dev/null +++ b/data/Test468.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List () +import {-# SOURCE #-} safe qualified Data.List hiding () diff --git a/data/Test469.hs b/data/Test469.hs new file mode 100644 --- /dev/null +++ b/data/Test469.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified Data.List () diff --git a/data/Test47.hs b/data/Test47.hs new file mode 100644 --- /dev/null +++ b/data/Test47.hs @@ -0,0 +1,4 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } diff --git a/data/Test470.hs b/data/Test470.hs new file mode 100644 --- /dev/null +++ b/data/Test470.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List (nub) diff --git a/data/Test471.hs b/data/Test471.hs new file mode 100644 --- /dev/null +++ b/data/Test471.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List (foldl', indexElem, nub) diff --git a/data/Test472.hs b/data/Test472.hs new file mode 100644 --- /dev/null +++ b/data/Test472.hs @@ -0,0 +1,16 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( Long + , anymore + , fit + , items + , line + , list + , not + , onA + , quite + , single + , that + , will + , with + ) diff --git a/data/Test473.hs b/data/Test473.hs new file mode 100644 --- /dev/null +++ b/data/Test473.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>))) diff --git a/data/Test474.hs b/data/Test474.hs new file mode 100644 --- /dev/null +++ b/data/Test474.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test hiding () +import Test as T hiding () diff --git a/data/Test475.hs b/data/Test475.hs new file mode 100644 --- /dev/null +++ b/data/Test475.hs @@ -0,0 +1,15 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Prelude as X + hiding + ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) diff --git a/data/Test476.hs b/data/Test476.hs new file mode 100644 --- /dev/null +++ b/data/Test476.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import MoreThanSufficientlyLongModuleNameWithSome + (compact, fit, inA, items, layout, not, that, will) +import TestJustAbitToLongModuleNameLikeThisOneIs () +import TestJustShortEnoughModuleNameLikeThisOne () diff --git a/data/Test477.hs b/data/Test477.hs new file mode 100644 --- /dev/null +++ b/data/Test477.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLikeThisOn as T diff --git a/data/Test478.hs b/data/Test478.hs new file mode 100644 --- /dev/null +++ b/data/Test478.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import TestJustAbitToLongModuleNameLikeTh hiding () +import TestJustShortEnoughModuleNameLike hiding () diff --git a/data/Test479.hs b/data/Test479.hs new file mode 100644 --- /dev/null +++ b/data/Test479.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import MoreThanSufficientlyLongModuleNameWithSome + (compact, fit, inA, items, layout, not, that, will) diff --git a/data/Test48.hs b/data/Test48.hs new file mode 100644 --- /dev/null +++ b/data/Test48.hs @@ -0,0 +1,4 @@ +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } diff --git a/data/Test480.hs b/data/Test480.hs new file mode 100644 --- /dev/null +++ b/data/Test480.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) diff --git a/data/Test481.hs b/data/Test481.hs new file mode 100644 --- /dev/null +++ b/data/Test481.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} diff --git a/data/Test482.hs b/data/Test482.hs new file mode 100644 --- /dev/null +++ b/data/Test482.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( abc + , def + -- comment + ) diff --git a/data/Test483.hs b/data/Test483.hs new file mode 100644 --- /dev/null +++ b/data/Test483.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( abc + -- comment + ) diff --git a/data/Test484.hs b/data/Test484.hs new file mode 100644 --- /dev/null +++ b/data/Test484.hs @@ -0,0 +1,12 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) +-- Test +import Test (test) diff --git a/data/Test485.hs b/data/Test485.hs new file mode 100644 --- /dev/null +++ b/data/Test485.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( -- comment + ) diff --git a/data/Test486.hs b/data/Test486.hs new file mode 100644 --- /dev/null +++ b/data/Test486.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test (longbindingNameThatoverflowsColum) +import Test (Long(List, Of, Things)) diff --git a/data/Test487.hs b/data/Test487.hs new file mode 100644 --- /dev/null +++ b/data/Test487.hs @@ -0,0 +1,27 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +import Test + ( Thing + ( Item + -- and Comment + ) + ) +import Test + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) + ) diff --git a/data/Test488.hs b/data/Test488.hs new file mode 100644 --- /dev/null +++ b/data/Test488.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + () diff --git a/data/Test489.hs b/data/Test489.hs new file mode 100644 --- /dev/null +++ b/data/Test489.hs @@ -0,0 +1,25 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE BangPatterns #-} +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ) where +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} +-- Test +import Test (test) diff --git a/data/Test49.hs b/data/Test49.hs new file mode 100644 --- /dev/null +++ b/data/Test49.hs @@ -0,0 +1,5 @@ +data Foo = Bar + { fooz :: Baz + , bar :: Bizzz + } + deriving Show diff --git a/data/Test490.hs b/data/Test490.hs new file mode 100644 --- /dev/null +++ b/data/Test490.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + abc <- foo +--abc +return () diff --git a/data/Test491.hs b/data/Test491.hs new file mode 100644 --- /dev/null +++ b/data/Test491.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (()) diff --git a/data/Test492.hs b/data/Test492.hs new file mode 100644 --- /dev/null +++ b/data/Test492.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + foo True = True + foo _ = False + return () diff --git a/data/Test493.hs b/data/Test493.hs new file mode 100644 --- /dev/null +++ b/data/Test493.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + foo True = True + foo _ = False + return () diff --git a/data/Test494.hs b/data/Test494.hs new file mode 100644 --- /dev/null +++ b/data/Test494.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + foo = True + b = False + return () diff --git a/data/Test495.hs b/data/Test495.hs new file mode 100644 --- /dev/null +++ b/data/Test495.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + let + foo = True + b = False + in return () diff --git a/data/Test496.hs b/data/Test496.hs new file mode 100644 --- /dev/null +++ b/data/Test496.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } diff --git a/data/Test497.hs b/data/Test497.hs new file mode 100644 --- /dev/null +++ b/data/Test497.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent state + , _lstate_foo = _lstate_foo state + } diff --git a/data/Test498.hs b/data/Test498.hs new file mode 100644 --- /dev/null +++ b/data/Test498.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo kasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test499.hs b/data/Test499.hs new file mode 100644 --- /dev/null +++ b/data/Test499.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = Foo { _lstate_indent = _lstate_indent state } diff --git a/data/Test5.hs b/data/Test5.hs new file mode 100644 --- /dev/null +++ b/data/Test5.hs @@ -0,0 +1,1 @@ +func :: (a -> a) -> a diff --git a/data/Test50.hs b/data/Test50.hs new file mode 100644 --- /dev/null +++ b/data/Test50.hs @@ -0,0 +1,8 @@ +data MyRecord = MyConstructor + { bar1, bar2 + :: Loooooooooooooooooooooooooooooooong + -> Loooooooooooooooooooooooooooooooong + , foo1, foo2 + :: Loooooooooooooooooooooooooooooooonger + -> Loooooooooooooooooooooooooooooooonger + } diff --git a/data/Test500.hs b/data/Test500.hs new file mode 100644 --- /dev/null +++ b/data/Test500.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test501.hs b/data/Test501.hs new file mode 100644 --- /dev/null +++ b/data/Test501.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test502.hs b/data/Test502.hs new file mode 100644 --- /dev/null +++ b/data/Test502.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do +-- abc + -- def + return () diff --git a/data/Test503.hs b/data/Test503.hs new file mode 100644 --- /dev/null +++ b/data/Test503.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + do + return () + -- abc + -- def + return () diff --git a/data/Test504.hs b/data/Test504.hs new file mode 100644 --- /dev/null +++ b/data/Test504.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +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/data/Test505.hs b/data/Test505.hs new file mode 100644 --- /dev/null +++ b/data/Test505.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + $ abc + $ def + $ ghi + $ jkl + ) diff --git a/data/Test506.hs b/data/Test506.hs new file mode 100644 --- /dev/null +++ b/data/Test506.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where reassoc (v, e, w) = (v, (e, w)) diff --git a/data/Test507.hs b/data/Test507.hs new file mode 100644 --- /dev/null +++ b/data/Test507.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +downloadRepoPackage = case repo of + RepoLocal {..} -> return () + RepoLocal { abc } -> return () + RepoLocal{} -> return () diff --git a/data/Test508.hs b/data/Test508.hs new file mode 100644 --- /dev/null +++ b/data/Test508.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' + (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' + -- default local dir target if there's no given target + utargets'' = "foo" + return () diff --git a/data/Test509.hs b/data/Test509.hs new file mode 100644 --- /dev/null +++ b/data/Test509.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + [ (thing, take 10 alts) --TODO: select best ones + | (thing, _got, alts@(_ : _)) <- nosuchFooThing + , gast <- award + ] diff --git a/data/Test51.hs b/data/Test51.hs new file mode 100644 --- /dev/null +++ b/data/Test51.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DatatypeContexts #-} +data + ( LooooooooooooooooooooongConstraint a + , LooooooooooooooooooooongConstraint b + ) => + MyRecord a b + = MyConstructor + { foo1, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } diff --git a/data/Test510.hs b/data/Test510.hs new file mode 100644 --- /dev/null +++ b/data/Test510.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = if x + then if y -- y is important + then foo + else bar + else Nothing diff --git a/data/Test511.hs b/data/Test511.hs new file mode 100644 --- /dev/null +++ b/data/Test511.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return $ Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR diff --git a/data/Test512.hs b/data/Test512.hs new file mode 100644 --- /dev/null +++ b/data/Test512.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +layoutWriteNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () diff --git a/data/Test513.hs b/data/Test513.hs new file mode 100644 --- /dev/null +++ b/data/Test513.hs @@ -0,0 +1,25 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +readMergePersConfig path shouldCreate conf = do + exists <- liftIO $ System.Directory.doesFileExist path + if + | exists -> do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn e + mzero + Right x -> return x + return $ fileConf Semigroup.<> conf + | shouldCreate -> do + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Option . Just . runIdentity) + staticDefaultConfig + return $ conf + | otherwise -> do + return conf diff --git a/data/Test514.hs b/data/Test514.hs new file mode 100644 --- /dev/null +++ b/data/Test514.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _) -> InstallOk diff --git a/data/Test515.hs b/data/Test515.hs new file mode 100644 --- /dev/null +++ b/data/Test515.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _) -> InstallOk diff --git a/data/Test516.hs b/data/Test516.hs new file mode 100644 --- /dev/null +++ b/data/Test516.hs @@ -0,0 +1,37 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +showPackageDetailedInfo pkginfo = + renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) + $ char '*' + $+$ something + [ entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry + "Versions available" + sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry + "Versions installed" + installedVersions + (altText + null + (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") + ) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) + then empty + else text "Modules:" + $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ] diff --git a/data/Test517.hs b/data/Test517.hs new file mode 100644 --- /dev/null +++ b/data/Test517.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +isValidPosition position + | validX && validY = Just position + | otherwise = Nothing diff --git a/data/Test518.hs b/data/Test518.hs new file mode 100644 --- /dev/null +++ b/data/Test518.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do + (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String + -> IO Bool) <- + ReflexHost.newExternalEvent + liftIO . forkIO . forever $ getLine >>= inputFire + ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent diff --git a/data/Test519.hs b/data/Test519.hs new file mode 100644 --- /dev/null +++ b/data/Test519.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- Test.hs +module Test where +data X = X diff --git a/data/Test52.hs b/data/Test52.hs new file mode 100644 --- /dev/null +++ b/data/Test52.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => Bar + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } diff --git a/data/Test520.hs b/data/Test520.hs new file mode 100644 --- /dev/null +++ b/data/Test520.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foldrDesc f z = unSwitchQueue $ \q -> + switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/data/Test521.hs b/data/Test521.hs new file mode 100644 --- /dev/null +++ b/data/Test521.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +autocheckCases = + [ ("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions", representative exceptionsNever) + , ("Consistent Result", alwaysSame) -- already representative + ] diff --git a/data/Test522.hs b/data/Test522.hs new file mode 100644 --- /dev/null +++ b/data/Test522.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +autocheckCases = + [ ("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions", representative exceptionsNever) + , ( "Consistent Result" + , alwaysSame -- already representative + ) + ] diff --git a/data/Test523.hs b/data/Test523.hs new file mode 100644 --- /dev/null +++ b/data/Test523.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + [ (abc, (1111, 1111)) + , (def, (2, 2)) + , foo -- comment + ] diff --git a/data/Test524.hs b/data/Test524.hs new file mode 100644 --- /dev/null +++ b/data/Test524.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + where g a b = b + b * a diff --git a/data/Test525.hs b/data/Test525.hs new file mode 100644 --- /dev/null +++ b/data/Test525.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo diff --git a/data/Test526.hs b/data/Test526.hs new file mode 100644 --- /dev/null +++ b/data/Test526.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + abc <- expr + abcccccccccccccccccc <- expr + abcccccccccccccccccccccccccccccccccccccccccc <- expr + abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr diff --git a/data/Test527.hs b/data/Test527.hs new file mode 100644 --- /dev/null +++ b/data/Test527.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (MyLongFoo abc def) = 1 +func (Bar a d) = 2 +func _ = 3 diff --git a/data/Test528.hs b/data/Test528.hs new file mode 100644 --- /dev/null +++ b/data/Test528.hs @@ -0,0 +1,15 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +parserCompactLocation = + [ try + $ [ ParseRelAbs (Text.Read.read digits) _ _ + | digits <- many1 digit + , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe + [ case divPart of + Nothing -> Left $ Text.Read.read digits + Just ddigits -> + Right $ Text.Read.read digits % Text.Read.read ddigits + | digits <- many1 digit + , divPart <- optionMaybe (string "/" *> many1 digit) + ] + ] + ] diff --git a/data/Test529.hs b/data/Test529.hs new file mode 100644 --- /dev/null +++ b/data/Test529.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test53.hs b/data/Test53.hs new file mode 100644 --- /dev/null +++ b/data/Test53.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a + . LooooooooooooooooooooongConstraint a => + LoooooooooooongConstructor + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } diff --git a/data/Test530.hs b/data/Test530.hs new file mode 100644 --- /dev/null +++ b/data/Test530.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + fooooooooooooooooooooooooooooooooo + + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test531.hs b/data/Test531.hs new file mode 100644 --- /dev/null +++ b/data/Test531.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + [ foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + ] diff --git a/data/Test532.hs b/data/Test532.hs new file mode 100644 --- /dev/null +++ b/data/Test532.hs @@ -0,0 +1,20 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +parserPrim = + [ r + | r <- + [ SGPPrimFloat $ bool id (0 -) minus $ readGnok + "parserPrim" + (d1 ++ d2 ++ d3 ++ d4) + | d2 <- string "." + , d3 <- many1 (oneOf "0123456789") + , _ <- string "f" + ] + <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "f" + ] + <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "i" + ] + ] diff --git a/data/Test533.hs b/data/Test533.hs new file mode 100644 --- /dev/null +++ b/data/Test533.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +samples = (SV.unpackaaaaadat) <&> \f -> + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test534.hs b/data/Test534.hs new file mode 100644 --- /dev/null +++ b/data/Test534.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +runBrittany tabSize text = do + let + config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text diff --git a/data/Test535.hs b/data/Test535.hs new file mode 100644 --- /dev/null +++ b/data/Test535.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE TypeApplications #-} +foo = bar @Baz diff --git a/data/Test536.hs b/data/Test536.hs new file mode 100644 --- /dev/null +++ b/data/Test536.hs @@ -0,0 +1,51 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE TypeApplications #-} +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do + docAlt + $ -- one-line solution + [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart + ] + ] + | not hasComments + , [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> [] + ] + ++ -- one-line solution + where in next line(s) + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , Data.Maybe.isJust mWhereDocs + ] + ++ -- two-line solution + where in next line(s) + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] diff --git a/data/Test537.hs b/data/Test537.hs new file mode 100644 --- /dev/null +++ b/data/Test537.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +func = do + let + foo = if + | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO + -> max + (defLen - 0.2) -- TODO + (defLen * 0.8) + | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO + return True diff --git a/data/Test538.hs b/data/Test538.hs new file mode 100644 --- /dev/null +++ b/data/Test538.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo n = case n of + 1 -> True + -1 -> False +bar n = case n of + (-2, -2) -> (-2, -2) diff --git a/data/Test539.hs b/data/Test539.hs new file mode 100644 --- /dev/null +++ b/data/Test539.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE TypeApplications #-} +foo = + let + a = b @1 + cccc = () + in foo diff --git a/data/Test54.hs b/data/Test54.hs new file mode 100644 --- /dev/null +++ b/data/Test54.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { a :: a + , b :: b + } diff --git a/data/Test540.hs b/data/Test540.hs new file mode 100644 --- /dev/null +++ b/data/Test540.hs @@ -0,0 +1,14 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +record :: Record +record = Record + { rProperties = + [ "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + ] + } diff --git a/data/Test55.hs b/data/Test55.hs new file mode 100644 --- /dev/null +++ b/data/Test55.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyStruct + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) diff --git a/data/Test56.hs b/data/Test56.hs new file mode 100644 --- /dev/null +++ b/data/Test56.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { foo, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + deriving Show diff --git a/data/Test57.hs b/data/Test57.hs new file mode 100644 --- /dev/null +++ b/data/Test57.hs @@ -0,0 +1,5 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test58.hs b/data/Test58.hs new file mode 100644 --- /dev/null +++ b/data/Test58.hs @@ -0,0 +1,12 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving Show + deriving (Eq, Ord) + deriving stock Show + deriving stock (Eq, Ord) + deriving anyclass Show + deriving anyclass (Show, Eq, Monad, Functor) + deriving newtype Show + deriving newtype (Traversable, Foldable) diff --git a/data/Test59.hs b/data/Test59.hs new file mode 100644 --- /dev/null +++ b/data/Test59.hs @@ -0,0 +1,6 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving ToJSON via (SomeType) + deriving (ToJSON, FromJSON) via (SomeType) diff --git a/data/Test6.hs b/data/Test6.hs new file mode 100644 --- /dev/null +++ b/data/Test6.hs @@ -0,0 +1,1 @@ +func :: a -> (a -> a) diff --git a/data/Test60.hs b/data/Test60.hs new file mode 100644 --- /dev/null +++ b/data/Test60.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} +data Foo = forall a . Show a => Bar + { foo :: a + } diff --git a/data/Test61.hs b/data/Test61.hs new file mode 100644 --- /dev/null +++ b/data/Test61.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExistentialQuantification #-} +data Foo = forall a b . (Show a, Eq b) => Bar + { foo :: a + , bars :: b + } diff --git a/data/Test62.hs b/data/Test62.hs new file mode 100644 --- /dev/null +++ b/data/Test62.hs @@ -0,0 +1,3 @@ +-- before +data MyData = MyData Int +-- after diff --git a/data/Test63.hs b/data/Test63.hs new file mode 100644 --- /dev/null +++ b/data/Test63.hs @@ -0,0 +1,5 @@ +data MyRecord = MyRecord + { a :: Int + -- comment + , b :: Int + } diff --git a/data/Test64.hs b/data/Test64.hs new file mode 100644 --- /dev/null +++ b/data/Test64.hs @@ -0,0 +1,5 @@ +data Foo = Bar -- a + { foo :: Baz -- b + , bars :: Bizzz -- c + } -- d + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e diff --git a/data/Test65.hs b/data/Test65.hs new file mode 100644 --- /dev/null +++ b/data/Test65.hs @@ -0,0 +1,9 @@ +data Foo = Bar + { -- a + foo -- b + :: -- c + Baz -- d + , -- e + bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test66.hs b/data/Test66.hs new file mode 100644 --- /dev/null +++ b/data/Test66.hs @@ -0,0 +1,11 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --b + ( -- c + ToJSON -- d + , -- e + FromJSON --f + ) -- g diff --git a/data/Test67.hs b/data/Test67.hs new file mode 100644 --- /dev/null +++ b/data/Test67.hs @@ -0,0 +1,13 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --a + ToJSON --b + via -- c + ( -- d + SomeType --e + , -- f + ABC --g + ) diff --git a/data/Test68.hs b/data/Test68.hs new file mode 100644 --- /dev/null +++ b/data/Test68.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} +data MyRecord + -- test comment + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor a b diff --git a/data/Test69.hs b/data/Test69.hs new file mode 100644 --- /dev/null +++ b/data/Test69.hs @@ -0,0 +1,4 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyLeft } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test7.hs b/data/Test7.hs new file mode 100644 --- /dev/null +++ b/data/Test7.hs @@ -0,0 +1,2 @@ +func :: (((((((((()))))))))) +-- current output is.. funny. wonder if that can/needs to be improved.. diff --git a/data/Test70.hs b/data/Test70.hs new file mode 100644 --- /dev/null +++ b/data/Test70.hs @@ -0,0 +1,3 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test71.hs b/data/Test71.hs new file mode 100644 --- /dev/null +++ b/data/Test71.hs @@ -0,0 +1,4 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test72.hs b/data/Test72.hs new file mode 100644 --- /dev/null +++ b/data/Test72.hs @@ -0,0 +1,3 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyMultiple } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test73.hs b/data/Test73.hs new file mode 100644 --- /dev/null +++ b/data/Test73.hs @@ -0,0 +1,22 @@ +data XIILqcacwiuNiu = XIILqcacwiuNiu + { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo + , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] + , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo + , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo + , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int + , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq + , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq + , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo + , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn + , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo + , opjUxtkxzkiKse_luqjuZazt + :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] + -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () + , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo + , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn + , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn + , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn + , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn + , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep + , jeyOcuesexaYoy_vpqn :: Jgtoyuh () + } diff --git a/data/Test74.hs b/data/Test74.hs new file mode 100644 --- /dev/null +++ b/data/Test74.hs @@ -0,0 +1,1 @@ +func x = x diff --git a/data/Test75.hs b/data/Test75.hs new file mode 100644 --- /dev/null +++ b/data/Test75.hs @@ -0,0 +1,1 @@ +x *** y = x diff --git a/data/Test76.hs b/data/Test76.hs new file mode 100644 --- /dev/null +++ b/data/Test76.hs @@ -0,0 +1,1 @@ +(***) x y = x diff --git a/data/Test77.hs b/data/Test77.hs new file mode 100644 --- /dev/null +++ b/data/Test77.hs @@ -0,0 +1,1 @@ +(f >=> g) k = f k >>= g diff --git a/data/Test78.hs b/data/Test78.hs new file mode 100644 --- /dev/null +++ b/data/Test78.hs @@ -0,0 +1,4 @@ +(Left a <$$> Left dd) e f = True +(Left a <$$> Right d ) e f = True +(Right a <$$> Left d ) e f = False +(Right a <$$> Right dd) e f = True diff --git a/data/Test79.hs b/data/Test79.hs new file mode 100644 --- /dev/null +++ b/data/Test79.hs @@ -0,0 +1,1 @@ +func _ = x diff --git a/data/Test8.hs b/data/Test8.hs new file mode 100644 --- /dev/null +++ b/data/Test8.hs @@ -0,0 +1,1 @@ +func :: () diff --git a/data/Test80.hs b/data/Test80.hs new file mode 100644 --- /dev/null +++ b/data/Test80.hs @@ -0,0 +1,2 @@ +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = + x diff --git a/data/Test81.hs b/data/Test81.hs new file mode 100644 --- /dev/null +++ b/data/Test81.hs @@ -0,0 +1,2 @@ +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x diff --git a/data/Test82.hs b/data/Test82.hs new file mode 100644 --- /dev/null +++ b/data/Test82.hs @@ -0,0 +1,2 @@ +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b + = x diff --git a/data/Test83.hs b/data/Test83.hs new file mode 100644 --- /dev/null +++ b/data/Test83.hs @@ -0,0 +1,1 @@ +func (A a) = a diff --git a/data/Test84.hs b/data/Test84.hs new file mode 100644 --- /dev/null +++ b/data/Test84.hs @@ -0,0 +1,1 @@ +func (x : xr) = x diff --git a/data/Test85.hs b/data/Test85.hs new file mode 100644 --- /dev/null +++ b/data/Test85.hs @@ -0,0 +1,1 @@ +func (x :+: xr) = x diff --git a/data/Test86.hs b/data/Test86.hs new file mode 100644 --- /dev/null +++ b/data/Test86.hs @@ -0,0 +1,1 @@ +func (x `Foo` xr) = x diff --git a/data/Test87.hs b/data/Test87.hs new file mode 100644 --- /dev/null +++ b/data/Test87.hs @@ -0,0 +1,1 @@ +func | True = x diff --git a/data/Test88.hs b/data/Test88.hs new file mode 100644 --- /dev/null +++ b/data/Test88.hs @@ -0,0 +1,2 @@ +func x | x = simple expression + | otherwise = 0 diff --git a/data/Test89.hs b/data/Test89.hs new file mode 100644 --- /dev/null +++ b/data/Test89.hs @@ -0,0 +1,3 @@ +func x + | a somewhat longer guard x = "and a somewhat longer expession that does not" + | otherwise = "fit without putting the guards in new lines" diff --git a/data/Test9.hs b/data/Test9.hs new file mode 100644 --- /dev/null +++ b/data/Test9.hs @@ -0,0 +1,5 @@ +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + ) diff --git a/data/Test90.hs b/data/Test90.hs new file mode 100644 --- /dev/null +++ b/data/Test90.hs @@ -0,0 +1,7 @@ +func x + | very long guard, another rather long guard that refers to x = nontrivial + expression + foo + bar + alsdkjlasdjlasj + | otherwise = 0 diff --git a/data/Test91.hs b/data/Test91.hs new file mode 100644 --- /dev/null +++ b/data/Test91.hs @@ -0,0 +1,5 @@ +func x + | very long guard, another rather long guard that refers to x + = nontrivialexpression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test92.hs b/data/Test92.hs new file mode 100644 --- /dev/null +++ b/data/Test92.hs @@ -0,0 +1,6 @@ +func x + | very loooooooooooooooooooooooooooooong guard + , another rather long guard that refers to x + = nontrivial expression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test93.hs b/data/Test93.hs new file mode 100644 --- /dev/null +++ b/data/Test93.hs @@ -0,0 +1,2 @@ +func = x +describe "infix op" $ do diff --git a/data/Test94.hs b/data/Test94.hs new file mode 100644 --- /dev/null +++ b/data/Test94.hs @@ -0,0 +1,1 @@ +func = x + x diff --git a/data/Test95.hs b/data/Test95.hs new file mode 100644 --- /dev/null +++ b/data/Test95.hs @@ -0,0 +1,3 @@ +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test96.hs b/data/Test96.hs new file mode 100644 --- /dev/null +++ b/data/Test96.hs @@ -0,0 +1,4 @@ +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj diff --git a/data/Test97.hs b/data/Test97.hs new file mode 100644 --- /dev/null +++ b/data/Test97.hs @@ -0,0 +1,4 @@ +func = + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test98.hs b/data/Test98.hs new file mode 100644 --- /dev/null +++ b/data/Test98.hs @@ -0,0 +1,5 @@ +func = 1 +func = "abc" +func = 1.1e5 +func = 'x' +func = 981409823458910394810928414192837123987123987123 diff --git a/data/Test99.hs b/data/Test99.hs new file mode 100644 --- /dev/null +++ b/data/Test99.hs @@ -0,0 +1,2 @@ +func = \x -> abc +describe "app" $ do diff --git a/data/brittany.yaml b/data/brittany.yaml new file mode 100644 --- /dev/null +++ b/data/brittany.yaml @@ -0,0 +1,4 @@ +conf_layout: + lconfig_allowSingleLineExportList: true + lconfig_importAsColumn: 60 + lconfig_importColumn: 60 diff --git a/source/executable/Main.hs b/source/executable/Main.hs new file mode 100644 --- /dev/null +++ b/source/executable/Main.hs @@ -0,0 +1,4 @@ +import qualified Language.Haskell.Brittany.Main as BrittanyMain + +main :: IO () +main = BrittanyMain.main diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany + ( parsePrintModule + , staticDefaultConfig + , forwardOptionsSyntaxExtsEnabled + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig + , Config + , CConfig(..) + , CDebugConfig(..) + , CLayoutConfig(..) + , CErrorHandlingConfig(..) + , CForwardOptions(..) + , CPreProcessorConfig(..) + , BrittanyError(..) + ) where + +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -0,0 +1,660 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.Brittany.Internal + ( parsePrintModule + , parsePrintModuleTests + , pPrintModule + , pPrintModuleAndCheck + -- re-export from utils: + , parseModule + , parseModuleFromString + , extractCommentConfigs + , getTopLevelDeclNameMap + ) where + +import Control.Monad.Trans.Except +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Char (isSpace) +import Data.HList.HList +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Yaml +import qualified GHC hiding (parseModule) +import GHC (GenLocated(L)) +import qualified GHC.Driver.Session as GHC +import GHC.Hs +import qualified GHC.LanguageExtensions.Type as GHC +import qualified GHC.OldList as List +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.SrcLoc (SrcSpan) +import Language.Haskell.Brittany.Internal.Backend +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Transformations.Alt +import Language.Haskell.Brittany.Internal.Transformations.Columns +import Language.Haskell.Brittany.Internal.Transformations.Floating +import Language.Haskell.Brittany.Internal.Transformations.Indent +import Language.Haskell.Brittany.Internal.Transformations.Par +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified UI.Butcher.Monadic as Butcher + + + +data InlineConfigTarget + = InlineConfigTargetModule + | InlineConfigTargetNextDecl -- really only next in module + | InlineConfigTargetNextBinding -- by name + | InlineConfigTargetBinding String + +extractCommentConfigs + :: ExactPrint.Anns + -> TopLevelDeclNameMap + -> Either (String, String) (CConfig Maybe, PerItemConfig) +extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do + let + commentLiness = + [ ( k + , [ x + | (ExactPrint.Comment x _ _, _) <- + ( ExactPrint.annPriorComments ann + ++ ExactPrint.annFollowingComments ann + ) + ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] + ) + | (k, ann) <- Map.toList anns + ] + let configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + ( ("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) + let + configParser = Butcher.addAlternatives + [ ( "commandline-config" + , \s -> "-" `isPrefixOf` dropWhile (== ' ') s + , cmdlineConfigParser + ) + , ( "yaml-config-document" + , \s -> "{" `isPrefixOf` dropWhile (== ' ') s + , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") + $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) + . either (const Nothing) Just + . Data.Yaml.decodeEither' + . Data.ByteString.Char8.pack + -- TODO: use some proper utf8 encoder instead? + ) + ] + parser = do -- we will (mis?)use butcher here to parse the inline config + -- line. + let nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + Butcher.addCmd "-next-declaration" nextDecl + Butcher.addCmd "-Next-Declaration" nextDecl + Butcher.addCmd "-NEXT-DECLARATION" nextDecl + let nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + Butcher.addCmd "-next-binding" nextBinding + Butcher.addCmd "-Next-Binding" nextBinding + Butcher.addCmd "-NEXT-BINDING" nextBinding + let disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) + Butcher.addCmd "-disable-next-binding" disableNextBinding + Butcher.addCmd "-Disable-Next-Binding" disableNextBinding + Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding + let disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) + Butcher.addCmd "-disable-next-declaration" disableNextDecl + Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl + Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + let disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) + Butcher.addCmd "-disable" disableFormatting + Butcher.addCmd "@" $ do + -- Butcher.addCmd "module" $ do + -- conf <- configParser + -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) + Butcher.addNullCmd $ do + bindingName <- Butcher.addParamString "BINDING" mempty + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetModule, conf) + lineConfigss <- configLiness `forM` \(k, ss) -> do + r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of + Left err -> Left $ (err, s) + Right c -> Right $ c + pure (k, r) + + let perModule = foldl' + (<>) + mempty + [ conf + | (_ , lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf ) <- lineConfigs + ] + let + perBinding = Map.fromListWith + (<>) + [ (n, conf) + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , n <- case target of + InlineConfigTargetBinding s -> [s] + InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> + [name] + _ -> [] + ] + let + perKey = Map.fromListWith + (<>) + [ (k, conf) + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , case target of + InlineConfigTargetNextDecl -> True + InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> + True + _ -> False + ] + + pure + $ ( perModule + , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } + ) + + +getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap +getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = + TopLevelDeclNameMap $ Map.fromList + [ (ExactPrint.mkAnnKey decl, name) + | decl <- decls + , (name : _) <- [getDeclBindingNames decl] + ] + + +-- | Exposes the transformation in an pseudo-pure fashion. The signature +-- contains `IO` due to the GHC API not exposing a pure parsing function, but +-- there should be no observable effects. +-- +-- Note that this function ignores/resets all config values regarding +-- debugging, i.e. it will never use `trace`/write to stderr. +-- +-- Note that the ghc parsing function used internally currently is wrapped in +-- `mask_`, so cannot be killed easily. If you don't control the input, you +-- may wish to put some proper upper bound on the input's size as a timeout +-- won't do. +parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) +parsePrintModule configWithDebugs inputText = runExceptT $ do + let config = + configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack + (anns, parsedSource, hasCPP) <- do + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + parseResult <- lift $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform $ Text.unpack inputText) + case parseResult of + Left err -> throwE [ErrorInput err] + Right x -> pure x + (inlineConf, perItemConf) <- + either (throwE . (: []) . uncurry ErrorMacroConfig) pure + $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack + if disableFormatting + then do + return inputText + else do + (errsWarns, outputTextL) <- do + let omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule moduleConfig perItemConf anns parsedSource + else lift + $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + pure $ if hackAroundIncludes + then + ( ews + , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn + (TextL.pack "\n") + outRaw + ) + else (ews, outRaw) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) + if hasErrors + then throwE $ errsWarns + else pure $ TextL.toStrict outputTextL + + + +-- BrittanyErrors can be non-fatal warnings, thus both are returned instead +-- of an Either. +-- This should be cleaned up once it is clear what kinds of errors really +-- can occur. +pPrintModule + :: Config + -> PerItemConfig + -> ExactPrint.Anns + -> GHC.ParsedSource + -> ([BrittanyError], TextL.Text) +pPrintModule conf inlineConf anns parsedModule = + let ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) + -- unless () $ do + -- + -- debugStrings `forM_` \s -> + -- trace s $ return () + +-- | Additionally checks that the output compiles again, appending an error +-- if it does not. +pPrintModuleAndCheck + :: Config + -> PerItemConfig + -> ExactPrint.Anns + -> GHC.ParsedSource + -> IO ([BrittanyError], TextL.Text) +pPrintModuleAndCheck conf inlineConf anns parsedModule = do + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let (errs, output) = pPrintModule conf inlineConf anns parsedModule + parseResult <- parseModuleFromString ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] + return (errs', output) + + +-- used for testing mostly, currently. +-- TODO: use parsePrintModule instead and remove this function. +parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) +parsePrintModuleTests conf filename input = do + let inputStr = Text.unpack input + parseResult <- parseModuleFromString + (conf & _conf_forward & _options_ghc & runIdentity) + filename + (const . pure $ Right ()) + inputStr + case parseResult of + Left err -> return $ Left err + Right (anns, parsedModule, _) -> runExceptT $ do + (inlineConf, perItemConf) <- + case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x + let moduleConf = cZipWith fromOptionIdentity conf inlineConf + let omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (errs, ltext) <- if omitCheck + then return $ pPrintModule moduleConf perItemConf anns parsedModule + else lift + $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule + if null errs + then pure $ TextL.toStrict $ ltext + else + let + errStrs = errs <&> \case + ErrorInput str -> str + ErrorUnusedComment str -> str + LayoutWarning str -> str + ErrorUnknownNode str _ -> str + ErrorMacroConfig str _ -> "when parsing inline config: " ++ str + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs + +-- this approach would for if there was a pure GHC.parseDynamicFilePragma. +-- Unfortunately that does not exist yet, so we cannot provide a nominally +-- pure interface. + +-- parsePrintModuleTests :: Text -> Either String Text +-- parsePrintModuleTests 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 +-- ErrorUnusedComment str -> str +-- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs +-- else return $ TextL.toStrict $ Text.Builder.toLazyText out + +toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a +toLocal conf anns m = do + (x, write) <- + lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m + MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) + pure x + +ppModule :: GenLocated SrcSpan HsModule -> PPM () +ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do + defaultAnns <- do + anns <- mAsk + let annKey = ExactPrint.mkAnnKey lmod + let annMap = Map.findWithDefault Map.empty annKey anns + let isEof = (== ExactPrint.AnnEofPos) + let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } + pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap + + post <- ppPreamble lmod + decls `forM_` \decl -> do + let declAnnKey = ExactPrint.mkAnnKey decl + let declBindingNames = getDeclBindingNames decl + inlineConf <- mAsk + let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf + let mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk + <&> \annMap -> + Map.union defaultAnns $ + Map.findWithDefault Map.empty declAnnKey annMap + + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns + + config <- mAsk + + let config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + + let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + toLocal config' filteredAnns $ do + bd <- if exactprintOnly + then briDocMToPPM $ briDocByExactNoComment decl + else do + (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl + mTell debugs + mTell errs + if null errs + then pure r + else briDocMToPPM $ briDocByExactNoComment decl + layoutBriDoc bd + + let finalComments = filter + (fst .> \case + ExactPrint.AnnComment{} -> True + _ -> False + ) + post + post `forM_` \case + (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do + ppmMoveToExactLoc l + mTell $ Text.Builder.fromString cmStr + (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> + let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + _ -> return () + +getDeclBindingNames :: LHsDecl GhcPs -> [String] +getDeclBindingNames (L _ decl) = case decl of + SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) + ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] + _ -> [] + + +-- Prints the information associated with the module annotation +-- This includes the imports +ppPreamble + :: GenLocated SrcSpan HsModule + -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] +ppPreamble lmod@(L loc m@HsModule{}) = do + filteredAnns <- mAsk <&> \annMap -> + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap + -- Since ghc-exactprint adds annotations following (implicit) + -- modules to both HsModule and the elements in the module + -- this can cause duplication of comments. So strip + -- attached annotations that come after the module's where + -- from the module node + config <- mAsk + let shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + + let + (filteredAnns', post) = + case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let + modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + mAnn' = mAnn { ExactPrint.annsDP = pre } + filteredAnns'' = + Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns + in + (filteredAnns'', post') + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' + + if shouldReformatPreamble + then toLocal config filteredAnns' $ withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + else + let emptyModule = L loc m { hsmodDecls = [] } + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + return post + +_sigHead :: Sig GhcPs -> String +_sigHead = \case + TypeSig _ names _ -> + "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) + _ -> "unknown sig" + +_bindHead :: HsBind GhcPs -> String +_bindHead = \case + FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) + PatBind _ _pat _ ([], []) -> "PatBind smth" + _ -> "unknown bind" + + + +layoutBriDoc :: BriDocNumbered -> PPMLocal () +layoutBriDoc briDoc = do + -- first step: transform the briDoc. + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + -- Note that briDoc is BriDocNumbered, but state type is BriDoc. + -- That's why the alt-transform looks a bit special here. + traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw + $ briDocToDoc + $ unwrapBriDocNumbered + $ briDoc + -- bridoc transformation: remove alts + transformAlts briDoc >>= mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyFloating .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating + -- bridoc transformation: par removal + mGet >>= transformSimplifyPar .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyColumns .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + -- bridoc transformation: indent + mGet >>= transformSimplifyIndent .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + + anns :: ExactPrint.Anns <- mAsk + + let state = LayoutState { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } + + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + + let remainingComments = + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] + remainingComments + `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) + + return $ () diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -0,0 +1,707 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.Brittany.Internal.Backend where + +import qualified Control.Monad.Trans.State.Strict as StateS +import qualified Data.Either as Either +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + + + +type ColIndex = Int + +data ColumnSpacing + = ColumnSpacingLeaf Int + | ColumnSpacingRef Int Int + +type ColumnBlock a = [a] +type ColumnBlocks a = Seq [a] +type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) + -- (ratio of hasSpace, maximum, raw) + +data ColInfo + = ColInfoStart -- start value to begin the mapAccumL. + | ColInfoNo BriDoc + | ColInfo ColIndex ColSig [(Int, ColInfo)] + +instance Show ColInfo where + show ColInfoStart = "ColInfoStart" + show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") + show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + +data ColBuildState = ColBuildState + { _cbs_map :: ColMap1 + , _cbs_index :: ColIndex + } + +type LayoutConstraints m = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) + +layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () +layoutBriDocM = \case + BDEmpty -> do + return () -- can it be that simple + BDLit t -> do + layoutIndentRestorePostComment + layoutRemoveIndentLevelLinger + layoutWriteAppend t + BDSeq list -> do + list `forM_` layoutBriDocM + -- in this situation, there is nothing to do about cols. + -- i think this one does not happen anymore with the current simplifications. + -- BDCols cSig list | BDPar sameLine lines <- List.last list -> + -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines + BDCols _ list -> do + list `forM_` layoutBriDocM + BDSeparator -> do + layoutAddSepSpace + BDAddBaseY indent bd -> do + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ layoutBriDocM bd + BDBaseYPushCur bd -> do + layoutBaseYPushCur + layoutBriDocM bd + BDBaseYPop bd -> do + layoutBriDocM bd + layoutBaseYPop + BDIndentLevelPushCur bd -> do + layoutIndentLevelPushCur + layoutBriDocM bd + BDIndentLevelPop bd -> do + layoutBriDocM bd + layoutIndentLevelPop + BDEnsureIndent indent bd -> do + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteEnsureBlock + layoutBriDocM bd + BDPar indent sameLine indented -> do + layoutBriDocM sameLine + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteNewlineBlock + layoutBriDocM indented + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt:_) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd + BDExternal annKey subKeys shouldAddComment t -> do + let tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines + anns :: ExactPrint.Anns <- mAsk + when shouldAddComment $ do + layoutWriteAppend + $ Text.pack + $ "{-" + ++ show (annKey, Map.lookup annKey anns) + ++ "-}" + zip [1 ..] tlines `forM_` \(i, l) -> do + layoutWriteAppend $ l + unless (i == tlineCount) layoutWriteNewlineBlock + do + state <- mGet + let filterF k _ = not $ k `Set.member` subKeys + mSet $ state + { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state + } + BDPlain t -> do + layoutWriteAppend t + BDAnnotationPrior annKey bd -> do + state <- mGet + let m = _lstate_comments state + let moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey + mAnn <- do + let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annPriorComments = [] }) + annKey + m + } + return mAnn + case mAnn of + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction + Just priors -> do + -- layoutResetSepSpace + priors + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + -- ^ evil hack for CPP + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + moveToExactLocationAction + layoutBriDocM bd + BDAnnotationKW annKey keyword bd -> do + layoutBriDocM bd + mComments <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let mToSpan = case mAnn of + Just anns | Maybe.isNothing keyword -> Just anns + Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just + annR + _ -> Nothing + case mToSpan of + Just anns -> do + let (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annsDP = rest }) + annKey + m + } + return $ nonEmpty comments + _ -> return Nothing + case mComments of + Nothing -> pure () + Just comments -> do + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDAnnotationRest annKey bd -> do + layoutBriDocM bd + annMay <- do + state <- mGet + let m = _lstate_comments state + pure $ Map.lookup annKey m + let mComments = nonEmpty . extractAllComments =<< annMay + let semiCount = length [ () + | Just ann <- [ annMay ] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- mAsk <&> + _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack + mModify $ \state -> state + { _lstate_comments = Map.adjust + ( \ann -> ann { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = + flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } + ) + annKey + (_lstate_comments state) + } + case mComments of + Nothing -> do + when shouldAddSemicolonNewlines $ do + [1..semiCount] `forM_` const layoutWriteNewline + Just comments -> do + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack comment + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) 1 + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do + mDP <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let relevant = [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] + -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] + case relevant of + [] -> pure Nothing + (ExactPrint.Types.DP (y, x):_) -> do + mSet state { _lstate_commentNewlines = 0 } + pure $ Just (y - _lstate_commentNewlines state, x) + case mDP of + Nothing -> pure () + Just (y, x) -> + -- we abuse this, as we probably will print the KW next, which is + -- _not_ a comment.. + layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 + layoutBriDocM bd + BDNonBottomSpacing _ bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd + BDDebug s bd -> do + mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" + layoutBriDocM bd + +briDocLineLength :: BriDoc -> Int +briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc + -- the state encodes whether a separator was already + -- appended at the current position. + where + rec = \case + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds + BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines ls@(_ : _) -> do + x <- StateS.get + return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd + +briDocIsMultiLine :: BriDoc -> Bool +briDocIsMultiLine briDoc = rec briDoc + where + rec :: BriDoc -> Bool + rec = \case + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t | [_] <- Text.lines t -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_ ] -> False + BDLines [] -> error "briDocIsMultiLine BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd + +-- In theory +-- ========= + +-- .. this algorithm works roughly in these steps: +-- +-- 1. For each line, get the (nested) column info, descending as far as +-- BDCols nodes go. The column info is a (rose) tree where the leafs +-- are arbitrary (non-BDCols) BriDocs. +-- 2. Walk through the lines and compare its column info with that of its +-- predecessor. If both are non-leafs and the column "signatures" align +-- (they don't align e.g. when they are totally different syntactical +-- structures or the number of children differs), mark these parts of +-- the two tree structures as connected and recurse to its children +-- (i.e. again comparing the children in this line with the children in +-- the previous line). +-- 3. What we now have is one tree per line, and connections between "same" +-- nodes between lines. These connection can span multiple lines. +-- We next look at spacing information. This is available at the leafs, +-- but in this step we aggregate _over connections_. At the top level, this +-- gives us one piece of data: How long would each line be, if we fully +-- aligned everything (kept all connections "active"). In contrast to +-- just taking the sum of all leafs for each tree, this line length includes +-- the spaces used for alignment. +-- 4. Treat those lines where alignment would result in overflowing of the +-- column limit. This "treatment" is currently configurable, and can e.g. +-- mean: +-- a) we stop alignment alltogether, +-- b) we remove alignment just from the overflowing lines, +-- c) we reduce the number of spaces inserted in overflowing lines using +-- some technique to make them not overflow, but without reducing the +-- space insertion to zero, +-- d) don't do anything +-- 5. Actually print the lines, walking over each tree and inserting spaces +-- according to the info and decisions gathered in the previous steps. +-- +-- Possible improvements +-- ===================== +-- +-- - If alignment is disabled for specific lines, the aggregated per-connection +-- info of those lines is still retained and not recalculated. This can +-- result in spaces being inserted to create alignment with a line that +-- would overflow and thus gets disabled entirely. +-- An better approach would be to repeat step 3 after marking overflowing +-- lines as such, and not include the overflowing spacings as references +-- for non-overflowing ones. In the simplest case one additional iteration +-- would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine +-- this and first remove alignment in the deepest parts of the tree for +-- overflowing lines, repeating and moving upwards until no lines are +-- anymore overflowing. +-- Further, it may make sense to break up connections when overflowing would +-- occur. +-- - It may also make sense to not filter all overflowing lines, but remove +-- them one-by-one and in each step recalculate the aggregated connection +-- spacing info. Because removing one overflowing line from the calculation +-- may very well cause another previously overflowing line to not overflow +-- any longer. +-- There is also a nasty optimization problem hiding in there (find the +-- minimal amount of alignment disabling that results in no overflows) +-- but that is overkill. +-- +-- (with both these improvements there would be quite some repetition between +-- steps 3 and 4, but it should be possible to ensure termination. Still, +-- performance might become an issue as such an approach is not necessarily +-- linear in bridoc size any more.) +-- +-- In practice +-- =========== +-- +-- .. the current implementation is somewhat sloppy. Steps 1 and 2 +-- are executed in one step, step 3 already applies one strategy that disables +-- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some +-- of the calculations one might expect to occur in step 3. Steps 4 and 5 +-- are executed in the same recursion, too. +-- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue +-- mentioned in the first "possible improvement". +alignColsLines :: LayoutConstraints m => [BriDoc] -> m () +alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do + -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) + curX <- do + state <- mGet + return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe + 0 + (_lstate_addSepSpace state) + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + alignBreak <- + mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack + case () of + _ -> do + -- tellDebugMess ("processedMap: " ++ show processedMap) + sequence_ + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos + <&> processInfo colMax processedMap + where + (colInfos, finalState) = + StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) + -- maxZipper :: [Int] -> [Int] -> [Int] + -- maxZipper [] ys = ys + -- maxZipper xs [] = xs + -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr + colAggregation :: [Int] -> Int + colAggregation [] = 0 -- this probably cannot happen the way we call + -- this function, because _cbs_map only ever + -- contains nonempty Seqs. + colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ] + where alignMax' = max 0 alignMax + + processedMap :: ColMap2 + processedMap = + fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + let + colss = colSpacingss <&> \spss -> case reverse spss of + [] -> [] + (xN:xR) -> + reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR + where + fLast (ColumnSpacingLeaf len ) = len + fLast (ColumnSpacingRef len _) = len + fInit (ColumnSpacingLeaf len) = len + fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of + Nothing -> 0 + Just (_, maxs, _) -> sum maxs + maxCols = {-Foldable.foldl1 maxZipper-} + fmap colAggregation $ transpose $ Foldable.toList colss + (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + counter count l = if List.last posXs + List.last l <= colMax + then count + 1 + else count + ratio = fromIntegral (foldl counter (0 :: Int) colss) + / fromIntegral (length colss) + in + (ratio, maxCols, colss) + + mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocs bds = mergeBriDocsW ColInfoStart bds + + mergeBriDocsW + :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd:bdr) = do + info <- mergeInfoBriDoc True lastInfo bd + infor <- mergeBriDocsW + -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) + (if shouldBreakAfter bd then ColInfoStart else info) + bdr + return $ info : infor + + -- even with alignBreak config flag, we don't stop aligning for certain + -- ColSigs - the ones with "False" below. The main reason is that + -- there are uses of BDCols where they provide the alignment of several + -- consecutive full larger code segments, for example ColOpPrefix. + -- Motivating example is + -- > foo + -- > $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -- > , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + -- > ] + -- > ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ] + -- If we break the alignment here, then all three lines for the first + -- list move left by one, which is horrible. We really don't want to + -- break whole-block alignments. + -- For list, listcomp, tuple and tuples the reasoning is much simpler: + -- alignment should not have much effect anyways, so i simply make the + -- choice here that enabling alignment is the safer route for preventing + -- potential glitches, and it should never have a negative effect. + -- For RecUpdate the argument is much less clear - it is mostly a + -- personal preference to not break alignment for those, even if + -- multiline. Really, this should be configurable.. (TODO) + shouldBreakAfter :: BriDoc -> Bool + shouldBreakAfter bd = alignBreak && + briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp{} _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True + + mergeInfoBriDoc + :: Bool + -> ColInfo + -> BriDoc + -> StateS.StateT ColBuildState Identity ColInfo + mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = + \case + brdc@(BDCols colSig subDocs) + | infoSig == colSig && length subLengthsInfos == length subDocs + -> do + let + isLastList = if lastFlag + then (==length subDocs) <$> [1 ..] + else repeat False + infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs + `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd + let curLengths = briDocLineLength <$> subDocs + let trueSpacings = getTrueSpacings (zip curLengths infos) + do -- update map + s <- StateS.get + let m = _cbs_map s + let (Just (_, spaces)) = IntMapS.lookup infoInd m + StateS.put s + { _cbs_map = IntMapS.insert + infoInd + (lastFlag, spaces Seq.|> trueSpacings) + m + } + return $ ColInfo infoInd colSig (zip curLengths infos) + | otherwise + -> briDocToColInfo lastFlag brdc + brdc -> return $ ColInfoNo brdc + +briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo +briDocToColInfo lastFlag = \case + BDCols sig list -> withAlloc lastFlag $ \ind -> do + let isLastList = + if lastFlag then (==length list) <$> [1 ..] else repeat False + subInfos <- zip isLastList list `forM` uncurry briDocToColInfo + let lengthInfos = zip (briDocLineLength <$> list) subInfos + let trueSpacings = getTrueSpacings lengthInfos + return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) + bd -> return $ ColInfoNo bd + +getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] +getTrueSpacings lengthInfos = lengthInfos <&> \case + (len, ColInfo i _ _) -> ColumnSpacingRef len i + (len, _ ) -> ColumnSpacingLeaf len + +withAlloc + :: Bool + -> ( ColIndex + -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) + ) + -> StateS.State ColBuildState ColInfo +withAlloc lastFlag f = do + cbs <- StateS.get + let ind = _cbs_index cbs + StateS.put $ cbs { _cbs_index = ind + 1 } + (space, info) <- f ind + StateS.get >>= \c -> StateS.put + $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } + return info + +processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () +processInfo maxSpace m = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ + do + colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack + curX <- do + state <- mGet + -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) + let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state + return $ case _lstate_curYOrAddNewline state of + Left i -> case _lstate_commentCol state of + Nothing -> spaceAdd + i + Just c -> c + Right{} -> spaceAdd + let colMax = min colMaxConf (curX + maxSpace) + -- tellDebugMess $ show curX + let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m + let maxCols2 = list <&> \case + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l + let maxCols = zipWith max maxCols1 maxCols2 + let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + -- handle the cases that the vertical alignment leads to more than max + -- cols: + -- this is not a full fix, and we must correct individually in addition. + -- because: the (at least) line with the largest element in the last + -- column will always still overflow, because we just updated the column + -- sizes in such a way that it works _if_ we have sizes (*factor) + -- in each column. but in that line, in the last column, we will be + -- forced to occupy the full vertical space, not reduced by any factor. + let fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (*factor) .> truncate + _ -> posXs + let spacings = zipWith (-) + (List.tail fixedPosXs ++ [min maxX colMax]) + fixedPosXs + -- tellDebugMess $ "ind = " ++ show ind + -- tellDebugMess $ "maxCols = " ++ show maxCols + -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs + -- tellDebugMess $ "list = " ++ show list + -- tellDebugMess $ "maxSpace = " ++ show maxSpace + let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. + then noAlignAct + else alignAct + case alignMode of + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeMajority limit | ratio >= limit -> animousAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct + +processInfoIgnore :: LayoutConstraints m => ColInfo -> m () +processInfoIgnore = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.BackendUtils where + +import qualified Data.Data +import qualified Data.Either +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (Located) +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint + + + +traceLocal + :: (MonadMultiState LayoutState m) + => a + -> m () +traceLocal _ = return () + + +layoutWriteAppend + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Text + -> m () +layoutWriteAppend t = do + traceLocal ("layoutWriteAppend", t) + state <- mGet + case _lstate_curYOrAddNewline state of + Right i -> do + replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" + Left{} -> do + return () + let spaces = fromMaybe 0 $ _lstate_addSepSpace state + mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') + mTell $ Text.Builder.fromText $ t + mModify $ \s -> s + { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces + , _lstate_addSepSpace = Nothing + } + +layoutWriteAppendSpaces + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Int + -> m () +layoutWriteAppendSpaces i = do + traceLocal ("layoutWriteAppendSpaces", i) + 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 + ) + => [Text] + -> m () +layoutWriteAppendMultiline ts = do + traceLocal ("layoutWriteAppendMultiline", ts) + case ts of + [] -> layoutWriteAppend (Text.pack "") -- 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 + ) + => m () +layoutWriteNewlineBlock = do + traceLocal ("layoutWriteNewlineBlock") + state <- mGet + mSet $ state { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ 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 isJust $ _lstate_addNewline state +-- then i +-- else _lstate_indLevelLinger state + i - _lstate_curY state +-- } + +layoutSetCommentCol + :: (MonadMultiState LayoutState m) => m () +layoutSetCommentCol = do + state <- mGet + let col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state + traceLocal ("layoutSetCommentCol", col) + unless (Data.Maybe.isJust $ _lstate_commentCol state) + $ mSet state { _lstate_commentCol = Just col } + +-- This is also used to move to non-comments in a couple of places. Seems +-- to be harmless so far.. +layoutMoveToCommentPos + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Int + -> Int + -> Int + -> m () +layoutMoveToCommentPos y x commentLines = do + traceLocal ("layoutMoveToCommentPos", y, x, commentLines) + state <- mGet + mSet state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right{} -> Right y + , _lstate_addSepSpace = + Just $ if Data.Maybe.isJust (_lstate_commentCol state) + then case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else if y == 0 then x else _lstate_indLevelLinger state + x + , _lstate_commentCol = + Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state + , _lstate_commentNewlines = + _lstate_commentNewlines state + y + commentLines - 1 + } + +-- | does _not_ add spaces to again reach the current base column. +layoutWriteNewline + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => m () +layoutWriteNewline = do + traceLocal ("layoutWriteNewline") + state <- mGet + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right (i + 1) + , _lstate_addSepSpace = Nothing + } + +_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () +_layoutResetCommentNewlines = do + mModify $ \state -> state { _lstate_commentNewlines = 0 } + +layoutWriteEnsureNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => m () +layoutWriteEnsureNewlineBlock = do + traceLocal ("layoutWriteEnsureNewlineBlock") + state <- mGet + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right $ max 1 i + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing + } + +layoutWriteEnsureAbsoluteN + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Int + -> m () +layoutWriteEnsureAbsoluteN n = do + state <- mGet + let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c , _ ) -> n - c + (Nothing, Left i ) -> n - i + (Nothing, Right{}) -> n + traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) + 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. + } + +layoutBaseYPushInternal + :: (MonadMultiState LayoutState m) + => Int + -> m () +layoutBaseYPushInternal i = do + traceLocal ("layoutBaseYPushInternal", i) + mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } + +layoutBaseYPopInternal + :: (MonadMultiState LayoutState m) => m () +layoutBaseYPopInternal = do + traceLocal ("layoutBaseYPopInternal") + mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } + +layoutIndentLevelPushInternal + :: (MonadMultiState LayoutState m) + => Int + -> m () +layoutIndentLevelPushInternal i = do + traceLocal ("layoutIndentLevelPushInternal", i) + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } + +layoutIndentLevelPopInternal + :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPopInternal = do + traceLocal ("layoutIndentLevelPopInternal") + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } + +layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () +layoutRemoveIndentLevelLinger = do + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + } + +layoutWithAddBaseCol + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + ) + => m () + -> m () +layoutWithAddBaseCol m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + m + layoutBaseYPopInternal + +layoutWithAddBaseColBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + ) + => m () + -> m () +layoutWithAddBaseColBlock m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutBaseYPopInternal + +layoutWithAddBaseColNBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Int + -> m () + -> m () +layoutWithAddBaseColNBlock amount m = do + traceLocal ("layoutWithAddBaseColNBlock", amount) + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutBaseYPopInternal + +layoutWriteEnsureBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => m () +layoutWriteEnsureBlock = do + traceLocal ("layoutWriteEnsureBlock") + state <- mGet + let + diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of + (Nothing, Left i ) -> lstate_baseY state - i + (Nothing, Right{}) -> lstate_baseY state + (Just sp, Left i ) -> max sp (lstate_baseY state - i) + (Just sp, Right{}) -> max sp (lstate_baseY state) + -- when (diff>0) $ layoutWriteNewlineBlock + when (diff > 0) $ do + mSet $ state { _lstate_addSepSpace = Just $ diff } + +layoutWithAddBaseColN + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Int + -> m () + -> m () +layoutWithAddBaseColN amount m = do + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + m + layoutBaseYPopInternal + +layoutBaseYPushCur + :: (MonadMultiState LayoutState m) => m () +layoutBaseYPushCur = do + traceLocal ("layoutBaseYPushCur") + state <- mGet + case _lstate_commentCol state of + Nothing -> + case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i , Just j ) -> layoutBaseYPushInternal (i + j) + (Left i , Nothing) -> layoutBaseYPushInternal i + (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state + Just cCol -> layoutBaseYPushInternal cCol + +layoutBaseYPop + :: (MonadMultiState LayoutState m) => m () +layoutBaseYPop = do + traceLocal ("layoutBaseYPop") + layoutBaseYPopInternal + +layoutIndentLevelPushCur + :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPushCur = do + traceLocal ("layoutIndentLevelPushCur") + state <- mGet + let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i , Just j ) -> i + j + (Left i , Nothing) -> i + (Right{}, Just j ) -> j + (Right{}, Nothing) -> 0 + layoutIndentLevelPushInternal y + +layoutIndentLevelPop + :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPop = do + traceLocal ("layoutIndentLevelPop") + layoutIndentLevelPopInternal + -- 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) + => m () +layoutAddSepSpace = do + 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 + ) + => AnnKey + -> m () +moveToExactAnn annKey = do + traceLocal ("moveToExactAnn", annKey) + anns <- mAsk + case Map.lookup annKey anns of + Nothing -> return () + Just ann -> do + -- curY <- mGet <&> _lstate_curY + let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann + -- mModify $ \state -> state { _lstate_addNewline = Just x } + moveToY y + +moveToY :: MonadMultiState LayoutState m => Int -> m () +moveToY y = mModify $ \state -> + let upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then + _lstate_commentCol state + <|> _lstate_addSepSpace state + <|> Just (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } +-- 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.DeltaPos + -> m () +ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do + replicateM_ x $ mTell $ Text.Builder.fromString "\n" + replicateM_ y $ mTell $ Text.Builder.fromString " " + +-- TODO: update and use, or clean up. Currently dead code. +layoutWritePriorComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Located ast + -> m () +layoutWritePriorComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns + } + return mAnn + case mAnn of + Nothing -> return () + Just priors -> do + unless (null priors) $ layoutSetCommentCol + priors `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment + +-- TODO: update and use, or clean up. Currently dead code. +-- this currently only extracs from the `annsDP` field of Annotations. +-- per documentation, this seems sufficient, as the +-- "..`annFollowingComments` are only added by AST transformations ..". +layoutWritePostComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Located ast -> m () +layoutWritePostComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns + } + return mAnn + case mAnn of + Nothing -> return () + Just posts -> do + unless (null posts) $ layoutSetCommentCol + posts `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment + +layoutIndentRestorePostComment + :: ( MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + ) + => m () +layoutIndentRestorePostComment = do + state <- mGet + let mCommentCol = _lstate_commentCol state + let eCurYAddNL = _lstate_curYOrAddNewline state + mModify $ \s -> s { _lstate_commentCol = Nothing + , _lstate_commentNewlines = 0 + } + case (mCommentCol, eCurYAddNL) of + (Just commentCol, Left{}) -> do + layoutWriteEnsureNewlineBlock + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) + _ -> return () + +-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, +-- MonadMultiWriter Text.Builder.Builder m, +-- MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) +-- => Located 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) +-- => Located ast -> m () +-- layoutWritePostCommentsRestore x = do +-- layoutWritePostComments x +-- layoutIndentRestorePostComment diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Config where + +import qualified Data.Bool as Bool +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Coerce (coerce) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Semigroup as Semigroup +import qualified Data.Yaml +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config.Types.Instances () +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Utils +import qualified System.Console.CmdArgs.Explicit as CmdArgs +import qualified System.Directory +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import UI.Butcher.Monadic + +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } +staticDefaultConfig :: Config +staticDefaultConfig = Config + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False + , _dconf_dump_bridoc_simpl_floating = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False + } + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) + , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_experimentalSemicolonNewlines = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _econf_omit_output_valid_check = coerce False + } + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort + , _ppconf_hackAroundIncludes = coerce False + } + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False + } + +forwardOptionsSyntaxExtsEnabled :: ForwardOptions +forwardOptionsSyntaxExtsEnabled = ForwardOptions + { _options_ghc = Identity + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] + } + +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } +cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) +cmdlineConfigParser = do + -- TODO: why does the default not trigger; ind never should be []!! + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") + + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged 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") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + + return $ Config + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = mempty + } + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty + , _lconfig_experimentalSemicolonNewlines = mempty + -- , _lconfig_allowSinglelineRecord = mempty + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty + , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck + } + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + } + where + falseToNothing = Bool.bool Nothing (Just True) + wrapLast :: Maybe a -> Maybe (Semigroup.Last a) + wrapLast = fmap Semigroup.Last + optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Maybe (f a) + optionConcat = mconcat . fmap (pure . pure) + +-- 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 +-- } + + +-- | Reads a config from a file. If the file does not exist, returns +-- Nothing. If the file exists and parsing fails, prints to stderr and +-- aborts the MaybeT. Otherwise succeed via Just. +-- If the second parameter is True and the file does not exist, writes the +-- staticDefaultConfig to the file. +readConfig + :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe)) +readConfig path = do + -- TODO: probably should catch IOErrors and then omit the existence check. + 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 + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) + mzero + Right x -> return x + return $ Just fileConf + else return $ Nothing + +-- | Looks for a user-global config file and return its path. +-- If there is no global config in a system, one will be created. +userConfigPath :: IO System.IO.FilePath +userConfigPath = do + userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + let searchDirs = [userBritPathSimple, userBritPathXdg] + globalConfig <- Directory.findFileWith Directory.doesFileExist + searchDirs + "config.yaml" + maybe (writeUserConfig userBritPathXdg) pure globalConfig + where + writeUserConfig dir = do + let createConfPath = dir FilePath. "config.yaml" + liftIO $ Directory.createDirectoryIfMissing True dir + writeDefaultConfig $ createConfPath + pure createConfPath + +-- | Searches for a local (per-project) brittany config starting from a given directory +findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) +findLocalConfigPath dir = do + let dirParts = FilePath.splitDirectories dir + -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] + let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) + Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" + +-- | Reads specified configs. +readConfigs + :: CConfig Maybe -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigs cmdlineConfig configPaths = do + configs <- readConfig `mapM` configPaths + let merged = Semigroup.sconcat + $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + return $ cZipWith fromOptionIdentity staticDefaultConfig merged + +-- | Reads provided configs +-- but also applies the user default configuration (with lowest priority) +readConfigsWithUserConfig + :: CConfig Maybe -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigsWithUserConfig cmdlineConfig configPaths = do + defaultPath <- liftIO $ userConfigPath + readConfigs cmdlineConfig (configPaths ++ [defaultPath]) + +writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () +writeDefaultConfig path = + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Just . runIdentity) + staticDefaultConfig + +showConfigYaml :: Config -> String +showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap + (\(Identity x) -> Just x) diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Haskell.Brittany.Internal.Config.Types where + +import Data.CZipWith +import Data.Coerce (Coercible, coerce) +import Data.Data (Data) +import qualified Data.Semigroup as Semigroup +import Data.Semigroup (Last) +import Data.Semigroup.Generic +import GHC.Generics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils () + + + +confUnpack :: Coercible a b => Identity a -> b +confUnpack (Identity x) = coerce x + +data CDebugConfig f = DebugConfig + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + } + deriving (Generic) + +data CLayoutConfig f = LayoutConfig + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + , _lconfig_indentPolicy :: f (Last IndentPolicy) + , _lconfig_indentAmount :: f (Last Int) + , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + -- when creating zero-indentation + -- multi-line list literals. + , _lconfig_importColumn :: f (Last Int) + -- ^ for import statement layouting, column at which to align the + -- elements to be imported from a module. + -- It is expected that importAsColumn >= importCol. + , _lconfig_importAsColumn :: f (Last Int) + -- ^ for import statement layouting, column at which put the module's + -- "as" name (which also affects the positioning of the "as" keyword). + -- It is expected that importAsColumn >= importCol. + , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) + , _lconfig_alignmentLimit :: f (Last Int) + -- roughly speaking, this sets an upper bound to the number of spaces + -- inserted to create horizontal alignment. + -- More specifically, if 'xs' are the widths of the columns in some + -- alignment-block, then the block will be aligned with the width + -- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ]. + , _lconfig_alignmentBreakOnMultiline :: f (Last Bool) + -- stops alignment between items that are not layouted as a single line. + -- e.g. for single-line alignment, things remain unchanged: + -- do + -- short <- stuff + -- loooooooong <- stuff + -- but not in cases such as: + -- do + -- short <- some more stuff + -- that requires two lines + -- loooooooong <- stuff + , _lconfig_hangingTypeSignature :: f (Last Bool) + -- Do not put "::" in a new line, and use hanging indentation for the + -- signature, i.e.: + -- func :: SomeLongStuff + -- -> SomeLongStuff + -- instead of the usual + -- func + -- :: SomeLongStuff + -- -> SomeLongStuff + -- As usual for hanging indentation, the result will be + -- context-sensitive (in the function name). + , _lconfig_reformatModulePreamble :: f (Last Bool) + -- whether the module preamble/header (module keyword, name, export list, + -- import statements) are reformatted. If false, only the elements of the + -- module (everything past the "where") are reformatted. + , _lconfig_allowSingleLineExportList :: f (Last Bool) + -- if true, and it fits in a single line, and there are no comments in the + -- export list, the following layout will be used: + -- > module MyModule (abc, def) where + -- > [stuff] + -- otherwise, the multi-line version is used: + -- > module MyModule + -- > ( abc + -- > , def + -- > ) + -- > where + , _lconfig_allowHangingQuasiQuotes :: f (Last Bool) + -- if false, the layouter sees any splices as infinitely big and places + -- them accordingly (in newlines, most likely); This also influences + -- parent nodes. + -- if true, the layouter is free to start a quasi-quotation at the end + -- of a line. + -- + -- false: + -- > let + -- > body = + -- > [json| + -- > hello + -- > |] + -- + -- true: + -- > let body = [json| + -- > hello + -- > |] + , _lconfig_experimentalSemicolonNewlines :: f (Last Bool) + -- enables an experimental feature to turn semicolons in brace notation + -- into newlines when using layout: + -- + -- > do { a ;; b } + -- + -- turns into + -- > do + -- > a + -- > + -- > b + -- + -- The implementation for this is a bit hacky and not tested; it might + -- break output syntax or not work properly for every kind of brace. So + -- far I have considered `do` and `case-of`. + -- , _lconfig_allowSinglelineRecord :: f (Last Bool) + -- -- if true, layouts record data decls as a single line when possible, e.g. + -- -- > MyPoint { x :: Double, y :: Double } + -- -- if false, always use the multi-line layout + -- -- > MyPoint + -- -- > { x :: Double + -- -- > , y :: Double + -- -- > } + } + deriving (Generic) + +data CForwardOptions f = ForwardOptions + { _options_ghc :: f [String] + } + deriving (Generic) + +data CErrorHandlingConfig f = ErrorHandlingConfig + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + -- ^ Determines when to fall back on the exactprint'ed output when + -- syntactical constructs are encountered which are not yet handled by + -- brittany. + -- Note that the "risky" setting is risky because even with the check of + -- the syntactic validity of the brittany output, at least in theory there + -- may be cases where the output is syntactically/semantically valid but + -- has different semantics than the code pre-transformation. + , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) + } + deriving (Generic) + +data CPreProcessorConfig f = PreProcessorConfig + { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) + , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) + } + deriving (Generic) + +data CConfig f = Config + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f + , _conf_errorHandling :: CErrorHandlingConfig f + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f + , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + -- ^ this field is somewhat of a duplicate of the one in DebugConfig. + -- It is used for per-declaration disabling by the inline config + -- implementation. Could have re-used the existing field, but felt risky + -- to use a "debug" labeled field for non-debug functionality. + , _conf_disable_formatting :: f (Semigroup.Last Bool) + -- ^ Used for inline config that disables brittany entirely for this + -- module. Useful for wildcard application + -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something + -- in that direction). + , _conf_obfuscate :: f (Semigroup.Last Bool) + + } + deriving (Generic) + +type DebugConfig = CDebugConfig Identity +type LayoutConfig = CLayoutConfig Identity +type ForwardOptions = CForwardOptions Identity +type ErrorHandlingConfig = CErrorHandlingConfig Identity +type Config = CConfig Identity + +-- i wonder if any Show1 stuff could be leveraged. +deriving instance Show (CDebugConfig Identity) +deriving instance Show (CLayoutConfig Identity) +deriving instance Show (CErrorHandlingConfig Identity) +deriving instance Show (CForwardOptions Identity) +deriving instance Show (CPreProcessorConfig Identity) +deriving instance Show (CConfig Identity) + +deriving instance Show (CDebugConfig Maybe) +deriving instance Show (CLayoutConfig Maybe) +deriving instance Show (CErrorHandlingConfig Maybe) +deriving instance Show (CForwardOptions Maybe) +deriving instance Show (CPreProcessorConfig Maybe) +deriving instance Show (CConfig Maybe) + +deriving instance Data (CDebugConfig Identity) +deriving instance Data (CLayoutConfig Identity) +deriving instance Data (CErrorHandlingConfig Identity) +deriving instance Data (CForwardOptions Identity) +deriving instance Data (CPreProcessorConfig Identity) +deriving instance Data (CConfig Identity) + +deriving instance Data (CDebugConfig Maybe) +deriving instance Data (CLayoutConfig Maybe) +deriving instance Data (CErrorHandlingConfig Maybe) +deriving instance Data (CForwardOptions Maybe) +deriving instance Data (CPreProcessorConfig Maybe) +deriving instance Data (CConfig Maybe) + +instance Semigroup.Semigroup (CDebugConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CLayoutConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CForwardOptions Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CConfig Maybe) where + (<>) = gmappend + +instance Semigroup.Semigroup (CDebugConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CLayoutConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CForwardOptions Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CPreProcessorConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CConfig Identity) where + (<>) = gmappend + +instance Monoid (CDebugConfig Maybe) where + mempty = gmempty +instance Monoid (CLayoutConfig Maybe) where + mempty = gmempty +instance Monoid (CErrorHandlingConfig Maybe) where + mempty = gmempty +instance Monoid (CForwardOptions Maybe) where + mempty = gmempty +instance Monoid (CPreProcessorConfig Maybe) where + mempty = gmempty +instance Monoid (CConfig Maybe) where + mempty = gmempty + + +data 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 (Eq, 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) + +data ColumnAlignMode + = ColumnAlignModeDisabled + -- ^ Make no column alignments whatsoever + | ColumnAlignModeUnanimously + -- ^ Make column alignments only if it does not cause overflow for any of + -- the affected lines. + | ColumnAlignModeMajority Float + -- ^ If at least (ratio::Float) of the aligned elements have sufficient + -- space for the alignment, act like ColumnAlignModeAnimously; otherwise + -- act like ColumnAlignModeDisabled. + | ColumnAlignModeAnimouslyScale Int + -- ^ Scale back columns to some degree if their sum leads to overflow. + -- This is done in a linear fashion. + -- The Int specifies additional columns to be added to column maximum for + -- scaling calculation purposes. + | ColumnAlignModeAnimously + -- ^ Decide on a case-by-case basis if alignment would cause overflow. + -- If it does, cancel all alignments for this (nested) column description. + -- ColumnAlignModeAnimouslySome -- potentially to implement + | ColumnAlignModeAlways + -- ^ Always respect column alignments, even if it makes stuff overflow. + deriving (Show, Generic, Data) + +data CPPMode = CPPModeAbort -- abort program on seeing -XCPP + | CPPModeWarn -- warn about CPP and non-roundtripping in its + -- presence. + | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is + -- file.) + deriving (Show, Generic, Data) + +data ExactPrintFallbackMode + = ExactPrintFallbackModeNever -- never fall back on exactprinting + | ExactPrintFallbackModeInline -- fall back only if there are no newlines in + -- the exactprint'ed output. + | ExactPrintFallbackModeRisky -- fall back even in the presence of newlines. + -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF + -- A PROGRAM BY TRANSFORMING IT. + deriving (Show, Generic, Data) + +deriveCZipWith ''CDebugConfig +deriveCZipWith ''CLayoutConfig +deriveCZipWith ''CErrorHandlingConfig +deriveCZipWith ''CForwardOptions +deriveCZipWith ''CPreProcessorConfig +deriveCZipWith ''CConfig + +instance CFunctor CDebugConfig +instance CFunctor CLayoutConfig +instance CFunctor CErrorHandlingConfig +instance CFunctor CForwardOptions +instance CFunctor CPreProcessorConfig +instance CFunctor CConfig diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -0,0 +1,121 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- These optimizations are disabled to improve compile times (and compilation +-- memory usage). When we do not disable them, the CI servers take more than +-- 10 minutes to compile this module alone. +-- Having looked into aeson and how the instances are written, I still do +-- not understand what makes GHC choke so much here. The size of the raw +-- expressions below looks fairly negligible, so there must be some expansion +-- due to inlining going on. But even disabling INLINE pragmas in aeson did +-- not seem to change anything. +-- Nonetheless, this solution works and has no downsides because the +-- instances defined here are not in any way performance-critical. +{-# OPTIONS_GHC -fno-pre-inlining #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fignore-interface-pragmas #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Config.Types.Instances where + +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.Types as Aeson +import Data.Yaml +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude + + + +aesonDecodeOptionsBrittany :: Aeson.Options +aesonDecodeOptionsBrittany = Aeson.defaultOptions + { Aeson.omitNothingFields = True + , Aeson.fieldLabelModifier = dropWhile (=='_') + } + +instance FromJSON (CDebugConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CDebugConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON IndentPolicy where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON IndentPolicy where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON AltChooser where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON AltChooser where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON ColumnAlignMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON ColumnAlignMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON CPPMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON CPPMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON ExactPrintFallbackMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON ExactPrintFallbackMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON (CLayoutConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CLayoutConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CErrorHandlingConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CErrorHandlingConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CForwardOptions Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CForwardOptions Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CPreProcessorConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CPreProcessorConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance ToJSON (CConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +-- This custom instance ensures the "omitNothingFields" behaviour not only for +-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid +-- config file content. +instance FromJSON (CConfig Maybe) where + parseJSON (Object v) = Config + <$> v .:? Key.fromString "conf_version" + <*> v .:?= Key.fromString "conf_debug" + <*> v .:?= Key.fromString "conf_layout" + <*> v .:?= Key.fromString "conf_errorHandling" + <*> v .:?= Key.fromString "conf_forward" + <*> v .:?= Key.fromString "conf_preprocessor" + <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" + <*> v .:? Key.fromString "conf_disable_formatting" + <*> v .:? Key.fromString "conf_obfuscate" + parseJSON invalid = Aeson.typeMismatch "Config" invalid + +-- Pretends that the value is {} when the key is not present. +(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a +o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.Brittany.Internal.ExactPrintUtils where + +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.Data +import qualified Data.Foldable as Foldable +import qualified Data.Generics as SYB +import Data.HList.HList +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import GHC (GenLocated(L)) +import qualified GHC hiding (parseModule) +import qualified GHC.Driver.CmdLine as GHC +import GHC.Hs +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.SrcLoc (Located, SrcSpan) +import Language.Haskell.Brittany.Internal.Config.Types +import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified System.IO + + + +parseModule + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModule args fp dynCheck = do + str <- System.IO.readFile fp + parseModuleFromString args fp dynCheck str + +parseModuleFromString + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> String + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModuleFromString = ParseModule.parseModule + + +commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () +commentAnnFixTransformGlob ast = do + let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` + (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) + let nodes = SYB.everything (<>) extract ast + let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (const id) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes + ] + nodes `forM_` (snd .> processComs annsMap) + where + processComs annsMap annKey1 = do + mAnn <- State.Class.gets fst <&> Map.lookup annKey1 + mAnn `forM_` \ann1 -> do + let priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 + let + processCom + :: (ExactPrint.Comment, ExactPrint.DeltaPos) + -> ExactPrint.TransformT Identity Bool + processCom comPair@(com, _) = + case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of + comLoc -> case Map.lookupLE comLoc annsMap of + Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of + (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> + move $> False + (x, y) | x == y -> move $> False + _ -> return True + where + ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 + ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 + move = ExactPrint.modifyAnnsT $ \anns -> + let + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2' = ann2 + { ExactPrint.annFollowingComments = + ExactPrint.annFollowingComments ann2 ++ [comPair] + } + in + Map.insert annKey2 ann2' anns + _ -> return True -- retain comment at current node. + priors' <- filterM processCom priors + follows' <- filterM processCom follows + assocs' <- flip filterM assocs $ \case + (ExactPrint.AnnComment com, dp) -> processCom (com, dp) + _ -> return True + let ann1' = ann1 { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } + ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns + + +-- TODO: this is unused by now, but it contains one detail that +-- commentAnnFixTransformGlob does not include: Moving of comments for +-- "RecordUpd"s. +-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransform modul = SYB.everything (>>) genF modul +-- where +-- genF :: Data.Data.Data a => a -> ExactPrint.Transform () +-- genF = (\_ -> return ()) `SYB.extQ` exprF +-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () +-- exprF lexpr@(L _ expr) = case expr of +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #else +-- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordUpd _ _e fs@(_:_) -> +-- #else +-- RecordUpd _e fs@(_:_) _cons _ _ _ -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- _ -> return () + +-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransform modul = SYB.everything (>>) genF modul +-- where +-- genF :: Data.Data.Data a => a -> ExactPrint.Transform () +-- genF = (\_ -> return ()) `SYB.extQ` exprF +-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () +-- exprF lexpr@(L _ expr) = case expr of +-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +-- moveTrailingComments lexpr (List.last fs) +-- RecordUpd _ _e fs@(_:_) -> +-- moveTrailingComments lexpr (List.last fs) +-- _ -> return () + +-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) +-- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () +-- moveTrailingComments astFrom astTo = do +-- let +-- k1 = ExactPrint.mkAnnKey astFrom +-- k2 = ExactPrint.mkAnnKey astTo +-- moveComments ans = ans' +-- where +-- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans +-- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans +-- cs1f = ExactPrint.annFollowingComments an1 +-- cs2f = ExactPrint.annFollowingComments an2 +-- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) +-- $ \case +-- (ExactPrint.AnnComment com, dp) -> Left (com, dp) +-- x -> Right x +-- an1' = an1 +-- { ExactPrint.annsDP = nonComments +-- , ExactPrint.annFollowingComments = [] +-- } +-- an2' = an2 +-- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments +-- } +-- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans + +-- ExactPrint.modifyAnnsT moveComments + +-- | split a set of annotations in a module into a map from top-level module +-- elements to the relevant annotations. Avoids quadratic behaviour a trivial +-- implementation would have. +extractToplevelAnns + :: Located HsModule + -> ExactPrint.Anns + -> Map ExactPrint.AnnKey ExactPrint.Anns +extractToplevelAnns lmod anns = output + where + (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod + declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap1 = Map.unions $ ldecls <&> \ldecl -> + Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) + declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap2 = + Map.fromList + $ [ (captured, declMap1 Map.! k) + | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns + ] + declMap = declMap1 `Map.union` declMap2 + modKey = ExactPrint.mkAnnKey lmod + output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + +groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) +groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) + Map.empty + where + insert k a Nothing = Just (Map.singleton k a) + insert k a (Just m) = Just (Map.insert k a m) + +foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey +foldedAnnKeys ast = SYB.everything + Set.union + ( \x -> maybe + Set.empty + Set.singleton + [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x + | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) + , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x + -- for some reason, ghc-8.8 has forgotten how to infer the type of l, + -- even though it is passed to mkAnnKey above, which only accepts + -- SrcSpan. + ] + ) + ast + where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) + + +withTransformedAnns + :: Data ast + => ast + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a +withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case + readers@(conf :+: anns :+: HNil) -> do + -- TODO: implement `local` for MultiReader/MultiRWS + MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) + x <- m + MultiRWSS.mPutRawR readers + pure x + where + f anns = + let ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced + + +warnExtractorCompat :: GHC.Warn -> String +warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -0,0 +1,781 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.LayouterBasics where + +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Writer.Strict as Writer +import qualified Data.Char as Char +import Data.Data +import qualified Data.Map as Map +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import DataTreePrint +import GHC (GenLocated(L), Located, moduleName, moduleNameString) +import qualified GHC.OldList as List +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.Name (getOccString) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName(..)) +import qualified GHC.Types.SrcLoc as GHC +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils + + + +processDefault + :: ( ExactPrint.Annotate.Annotate ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiReader ExactPrint.Types.Anns m + ) + => Located ast + -> m () +processDefault x = do + anns <- mAsk + let str = ExactPrint.exactPrint x anns + -- this hack is here so our print-empty-module trick does not add + -- a newline at the start if there actually is no module header / imports + -- / anything. + -- TODO: instead the appropriate annotation could be removed when "cleaning" + -- the module (header). This would remove the need for this hack! + case str of + "\n" -> return () + _ -> mTell $ Text.Builder.fromString str + +-- | Use ExactPrint's output for this node; add a newly generated inline comment +-- at insertion position (meant to point out to the user that this node is +-- not handled by brittany yet). Useful when starting implementing new +-- syntactic constructs when children are not handled yet. +briDocByExact + :: (ExactPrint.Annotate.Annotate ast) + => Located ast + -> ToBriDocM BriDocNumbered +briDocByExact ast = do + anns <- mAsk + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + docExt ast anns True + +-- | Use ExactPrint's output for this node. +-- Consider that for multi-line input, the indentation of the code produced +-- by ExactPrint might be different, and even incompatible with the indentation +-- of its surroundings as layouted by brittany. But there are safe uses of +-- this, e.g. for any top-level declarations. +briDocByExactNoComment + :: (ExactPrint.Annotate.Annotate ast) + => Located ast + -> ToBriDocM BriDocNumbered +briDocByExactNoComment ast = do + anns <- mAsk + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + docExt ast anns False + +-- | Use ExactPrint's output for this node, presuming that this output does +-- not contain any newlines. If this property is not met, the semantics +-- depend on the @econf_AllowRiskyExactPrintUse@ config flag. +briDocByExactInlineOnly + :: (ExactPrint.Annotate.Annotate ast) + => String + -> Located ast + -> ToBriDocM BriDocNumbered +briDocByExactInlineOnly infoStr ast = do + anns <- mAsk + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns + fallbackMode <- + mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack + let exactPrintNode t = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + t + let errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit + $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + case (fallbackMode, Text.lines exactPrinted) of + (ExactPrintFallbackModeNever, _ ) -> errorAction + (_ , [t]) -> exactPrintNode + (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) + (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted + _ -> errorAction + +rdrNameToText :: RdrName -> Text +-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr +rdrNameToText (Unqual occname) = Text.pack $ occNameString occname +rdrNameToText (Qual mname occname) = + Text.pack $ moduleNameString mname ++ "." ++ occNameString occname +rdrNameToText (Orig modul occname) = + Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname +rdrNameToText (Exact name) = Text.pack $ getOccString name + +lrdrNameToText :: GenLocated l RdrName -> Text +lrdrNameToText (L _ n) = rdrNameToText n + +lrdrNameToTextAnnGen + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => (Text -> Text) + -> Located RdrName + -> m Text +lrdrNameToTextAnnGen f ast@(L _ n) = do + anns <- mAsk + let t = f $ rdrNameToText n + let hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False + -- TODO: in general: we should _always_ process all annotaiton stuff here. + -- whatever we don't probably should have had some effect on the + -- output. in such cases, resorting to byExact is probably the safe + -- choice. + return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> t + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + _ | any (hasUni AnnCommaTuple) aks -> t + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t + +lrdrNameToTextAnn + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => Located RdrName + -> m Text +lrdrNameToTextAnn = lrdrNameToTextAnnGen id + +lrdrNameToTextAnnTypeEqualityIsSpecial + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => Located RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecial ast = do + let f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + lrdrNameToTextAnnGen f ast + +-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects +-- the annotations for a (parent) node for a tick to be added to the +-- literal. +-- Excessively long name to reflect on us having to work around such +-- excessively obscure special cases in the exactprint API. +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick + :: ( Data ast + , MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => Located ast + -> Located RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do + hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote + x <- lrdrNameToTextAnn ast2 + let lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + return $ if hasQuote then Text.cons '\'' lit else lit + +askIndent :: (MonadMultiReader Config m) => m Int +askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk + + +extractAllComments + :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +extractAllComments ann = + ExactPrint.annPriorComments ann ++ extractRestComments ann + +extractRestComments + :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +extractRestComments ann = + ExactPrint.annFollowingComments ann + ++ (ExactPrint.annsDP ann >>= \case + (ExactPrint.AnnComment com, dp) -> [(com, dp)] + _ -> [] + ) + +filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns +filterAnns ast = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) + +-- | True if there are any comments that are +-- a) connected to any node below (in AST sense) the given node AND +-- b) after (in source code order) the node. +hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsBelow ast@(L l _) = + List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) + <$> astConnectedComments ast + +hasCommentsBetween + :: Data ast + => GHC.Located ast + -> AnnKeywordId + -> AnnKeywordId + -> ToBriDocM Bool +hasCommentsBetween ast leftKey rightKey = do + mAnn <- astAnn ast + let go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest + case mAnn of + Nothing -> pure False + Just ann -> pure $ go1 $ ExactPrint.annsDP ann + +-- | True if there are any comments that are connected to any node below (in AST +-- sense) the given node +hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast + +-- | True if there are any regular comments connected to any node below (in AST +-- sense) the given node +hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected ast = + any isRegularComment <$> astConnectedComments ast + +-- | Regular comments are comments that are actually "source code comments", +-- i.e. things that start with "--" or "{-". In contrast to comment-annotations +-- used by ghc-exactprint for capturing symbols (and their exact positioning). +-- +-- Only the type instance layouter makes use of this filter currently, but +-- it might make sense to apply it more aggressively or make it the default - +-- I believe that most of the time we branch on the existence of comments, we +-- only care about "regular" comments. We simply did not need the distinction +-- because "irregular" comments are not that common outside of type/data decls. +isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool +isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst + +astConnectedComments + :: Data ast + => GHC.Located ast + -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] +astConnectedComments ast = do + anns <- filterAnns ast <$> mAsk + pure $ extractAllComments =<< Map.elems anns + +hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsPrior ast = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + +hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsRest ast = astAnn ast <&> \case + Nothing -> False + Just ann -> any isRegularComment (extractRestComments ann) + +hasAnnKeywordComment + :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just ann -> any hasK (extractAllComments ann) + where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + +hasAnnKeyword + :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) + => Located a + -> AnnKeywordId + -> m Bool +hasAnnKeyword ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + where + hasK (ExactPrint.Types.G x, _) = x == annKeyword + hasK _ = False + +astAnn + :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) + => GHC.Located ast + -> m (Maybe Annotation) +astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk + +-- new BriDoc stuff + +allocateNode + :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered +allocateNode bd = do + i <- allocNodeIndex + return (i, bd) + +allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int +allocNodeIndex = do + NodeAllocIndex i <- mGet + mSet $ NodeAllocIndex (i + 1) + return i + +-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docEmpty = allocateNode BDFEmpty +-- +-- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered +-- docLit t = allocateNode $ BDFLit t +-- +-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) +-- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered +-- docExt x anns shouldAddComment = allocateNode $ BDFExternal +-- (ExactPrint.Types.mkAnnKey x) +-- (foldedAnnKeys x) +-- shouldAddComment +-- (Text.pack $ ExactPrint.exactPrint x anns) +-- +-- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered +-- docAlt l = allocateNode . BDFAlt =<< sequence l +-- +-- +-- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered +-- docSeq l = allocateNode . BDFSeq =<< sequence l +-- +-- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered +-- docLines l = allocateNode . BDFLines =<< sequence l +-- +-- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered +-- docCols sig l = allocateNode . BDFCols sig =<< sequence l +-- +-- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered +-- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm +-- +-- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm +-- +-- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm +-- +-- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docSeparator = allocateNode BDFSeparator +-- +-- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered +-- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm +-- +-- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered +-- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm +-- +-- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm +-- +-- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- appSep x = docSeq [x, docSeparator] +-- +-- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docCommaSep = appSep $ docLit $ Text.pack "," +-- +-- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docParenLSep = appSep $ docLit $ Text.pack "(" +-- +-- +-- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) +-- => Located ast +-- -> m BriDocNumbered +-- -> m BriDocNumbered +-- docPostComment ast bdm = do +-- bd <- bdm +-- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd +-- +-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) +-- => Located ast +-- -> m BriDocNumbered +-- -> m BriDocNumbered +-- docWrapNode ast bdm = do +-- bd <- bdm +-- i1 <- allocNodeIndex +-- i2 <- allocNodeIndex +-- return +-- $ (,) i1 +-- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) +-- $ (,) i2 +-- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) +-- $ bd +-- +-- docPar :: MonadMultiState NodeAllocIndex m +-- => m BriDocNumbered +-- -> m BriDocNumbered +-- -> m BriDocNumbered +-- docPar lineM indentedM = do +-- line <- lineM +-- indented <- indentedM +-- allocateNode $ BDFPar BrIndentNone line indented +-- +-- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm +-- +-- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm +-- +-- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered +-- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd + +docEmpty :: ToBriDocM BriDocNumbered +docEmpty = allocateNode BDFEmpty + +docLit :: Text -> ToBriDocM BriDocNumbered +docLit t = allocateNode $ BDFLit t + +docLitS :: String -> ToBriDocM BriDocNumbered +docLitS s = allocateNode $ BDFLit $ Text.pack s + +docExt + :: (ExactPrint.Annotate.Annotate ast) + => Located ast + -> ExactPrint.Types.Anns + -> Bool + -> ToBriDocM BriDocNumbered +docExt x anns shouldAddComment = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey x) + (foldedAnnKeys x) + shouldAddComment + (Text.pack $ ExactPrint.exactPrint x anns) + +docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docAlt l = allocateNode . BDFAlt =<< sequence l + +newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) + deriving (Functor, Applicative, Monad) + +addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () +addAlternativeCond cond doc = + when cond (addAlternative doc) + +addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () +addAlternative = + CollectAltM . Writer.tell . (: []) + +runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered +runFilteredAlternative (CollectAltM action) = + docAlt $ Writer.execWriter action + + +docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docSeq [] = docEmpty +docSeq l = allocateNode . BDFSeq =<< sequence l + +docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docLines l = allocateNode . BDFLines =<< sequence l + +docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docCols sig l = allocateNode . BDFCols sig =<< sequence l + +docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm + +docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetBaseY bdm = do + bd <- bdm + -- the order here is important so that these two nodes can be treated + -- properly over at `transformAlts`. + n1 <- allocateNode $ BDFBaseYPushCur bd + n2 <- allocateNode $ BDFBaseYPop n1 + return n2 + +docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetIndentLevel bdm = do + bd <- bdm + n1 <- allocateNode $ BDFIndentLevelPushCur bd + n2 <- allocateNode $ BDFIndentLevelPop n1 + return n2 + +docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetBaseAndIndent = docSetBaseY . docSetIndentLevel + +docSeparator :: ToBriDocM BriDocNumbered +docSeparator = allocateNode BDFSeparator + +docAnnotationPrior + :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAnnotationPrior annKey bdm = + allocateNode . BDFAnnotationPrior annKey =<< bdm + +docAnnotationKW + :: AnnKey + -> Maybe AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm + +docMoveToKWDP + :: AnnKey + -> AnnKeywordId + -> Bool + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docMoveToKWDP annKey kw shouldRestoreIndent bdm = + allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm + +docAnnotationRest + :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm + +docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm + +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm + +docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm + +docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm + +docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docDebug s bdm = allocateNode . BDFDebug s =<< bdm + +appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +appSep x = docSeq [x, docSeparator] + +docCommaSep :: ToBriDocM BriDocNumbered +docCommaSep = appSep $ docLit $ Text.pack "," + +docParenLSep :: ToBriDocM BriDocNumbered +docParenLSep = appSep docParenL + +-- TODO: we don't make consistent use of these (yet). However, I think the +-- most readable approach overall might be something else: define +-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. +-- I think those two would make the usage most readable. +-- lit "(" and appSep (lit "(") are understandable and short without +-- introducing a new top-level binding for all types of parentheses. +docParenL :: ToBriDocM BriDocNumbered +docParenL = docLit $ Text.pack "(" + +docParenR :: ToBriDocM BriDocNumbered +docParenR = docLit $ Text.pack ")" + +docParenHashLSep :: ToBriDocM BriDocNumbered +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] + +docParenHashRSep :: ToBriDocM BriDocNumbered +docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] + +docBracketL :: ToBriDocM BriDocNumbered +docBracketL = docLit $ Text.pack "[" + +docBracketR :: ToBriDocM BriDocNumbered +docBracketR = docLit $ Text.pack "]" + + +docTick :: ToBriDocM BriDocNumbered +docTick = docLit $ Text.pack "'" + +docNodeAnnKW + :: Data.Data.Data ast + => Located ast + -> Maybe AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docNodeAnnKW ast kw bdm = + docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm + +docNodeMoveToKWDP + :: Data.Data.Data ast + => Located ast + -> AnnKeywordId + -> Bool + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm + +class DocWrapable a where + docWrapNode :: ( Data.Data.Data ast) + => Located ast + -> a + -> a + docWrapNodePrior :: ( Data.Data.Data ast) + => Located ast + -> a + -> a + docWrapNodeRest :: ( Data.Data.Data ast) + => Located ast + -> a + -> a + +instance DocWrapable (ToBriDocM BriDocNumbered) where + docWrapNode ast bdm = do + bd <- bdm + i1 <- allocNodeIndex + i2 <- allocNodeIndex + return + $ (,) i1 + $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ (,) i2 + $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) + $ bd + docWrapNodePrior ast bdm = do + bd <- bdm + i1 <- allocNodeIndex + return + $ (,) i1 + $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ bd + docWrapNodeRest ast bdm = do + bd <- bdm + i2 <- allocNodeIndex + return + $ (,) i2 + $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) + $ bd + +instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where + docWrapNode ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNode ast bd] + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> + [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] + _ -> error "cannot happen (TM)" + docWrapNodePrior ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNodePrior ast bd] + (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR + docWrapNodeRest ast bdms = case reverse bdms of + [] -> [] + (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where + docWrapNode ast bdsm = do + bds <- bdsm + case bds of + [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. + [bd] -> do + bd' <- docWrapNode ast (return bd) + return [bd'] + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do + bd1' <- docWrapNodePrior ast (return bd1) + bdN' <- docWrapNodeRest ast (return bdN) + return $ [bd1'] ++ reverse bdM ++ [bdN'] + _ -> error "cannot happen (TM)" + docWrapNodePrior ast bdsm = do + bds <- bdsm + case bds of + [] -> return [] + (bd1:bdR) -> do + bd1' <- docWrapNodePrior ast (return bd1) + return (bd1':bdR) + docWrapNodeRest ast bdsm = do + bds <- bdsm + case reverse bds of + [] -> return [] + (bdN:bdR) -> do + bdN' <- docWrapNodeRest ast (return bdN) + return $ reverse (bdN':bdR) + +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where + docWrapNode ast bdsm = do + bds <- bdsm + case Seq.viewl bds of + Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. + bd1 Seq.:< rest -> case Seq.viewr rest of + Seq.EmptyR -> do + bd1' <- docWrapNode ast (return bd1) + return $ Seq.singleton bd1' + bdM Seq.:> bdN -> do + bd1' <- docWrapNodePrior ast (return bd1) + bdN' <- docWrapNodeRest ast (return bdN) + return $ (bd1' Seq.<| bdM) Seq.|> bdN' + docWrapNodePrior ast bdsm = do + bds <- bdsm + case Seq.viewl bds of + Seq.EmptyL -> return Seq.empty + bd1 Seq.:< bdR -> do + bd1' <- docWrapNodePrior ast (return bd1) + return $ bd1' Seq.<| bdR + docWrapNodeRest ast bdsm = do + bds <- bdsm + case Seq.viewr bds of + Seq.EmptyR -> return Seq.empty + bdR Seq.:> bdN -> do + bdN' <- docWrapNodeRest ast (return bdN) + return $ bdR Seq.|> bdN' + +instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where + docWrapNode ast stuffM = do + (bds, bd, x) <- stuffM + if null bds + then do + bd' <- docWrapNode ast (return bd) + return (bds, bd', x) + else do + bds' <- docWrapNodePrior ast (return bds) + bd' <- docWrapNodeRest ast (return bd) + return (bds', bd', x) + docWrapNodePrior ast stuffM = do + (bds, bd, x) <- stuffM + bds' <- docWrapNodePrior ast (return bds) + return (bds', bd, x) + docWrapNodeRest ast stuffM = do + (bds, bd, x) <- stuffM + bd' <- docWrapNodeRest ast (return bd) + return (bds, bd', x) + + + +docPar + :: ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docPar lineM indentedM = do + line <- lineM + indented <- indentedM + allocateNode $ BDFPar BrIndentNone line indented + +docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm + +docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm + +docEnsureIndent + :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd + +unknownNodeError + :: Data.Data.Data ast + => String + -> GenLocated GHC.SrcSpan ast + -> ToBriDocM BriDocNumbered +unknownNodeError infoStr ast = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + +spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] +spacifyDocs [] = [] +spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] + +briDocMToPPM :: ToBriDocM a -> PPMLocal a +briDocMToPPM m = do + (x, errs, debugs) <- briDocMToPPMInner m + mTell debugs + mTell errs + return x + +briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) +briDocMToPPMInner m = do + readers <- MultiRWSS.mGetRawR + let ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m + pure (x, errs, debugs) + +docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) +docSharedWrapper f x = return <$> f x diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.DataDecl where + +import qualified Data.Data +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (GenLocated(L), Located) +import qualified GHC +import GHC.Hs +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types + + + +layoutDataDecl + :: Located (TyClDecl GhcPs) + -> Located RdrName + -> LHsQTyVars GhcPs + -> HsDataDefn GhcPs + -> ToBriDocM BriDocNumbered +layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of + -- newtype MyType a b = MyType .. + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> + docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl + + + -- data MyData a b + -- (zero constructors) + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> + docWrapNode ltycl $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "data" + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + ] + + -- data MyData = MyData .. + -- data MyData = MyData { .. } + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> + docWrapNode ltycl $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of + Nothing -> pure Nothing + Just x -> Just . pure <$> x + rhsContextDocMay <- case mRhsContext of + Nothing -> pure Nothing + Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt + rhsDoc <- return <$> createDetailsDoc consNameStr details + consDoc <- fmap pure + $ docNonBottomSpacing + $ case (forallDocMay, rhsContextDocMay) of + (Just forallDoc, Just rhsContextDoc) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq + [ docLitS "." + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + ] + (Just forallDoc, Nothing) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq [docLitS ".", docSeparator, rhsDoc] + ] + (Nothing, Just rhsContextDoc) -> docSeq + [ docLitS "=" + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] + createDerivingPar mDerivs $ docAlt + [ -- data D = forall a . Show a => D a + docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline $ lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + ] + , docLitS "=" + , docSeparator + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ] + , -- data D + -- = forall a . Show a => D a + docAddBaseY BrIndentRegular $ docPar + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + ( docSeq + [ docLitS "=" + , docSeparator + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ] + ) + , -- data D + -- = forall a + -- . Show a => + -- D a + docAddBaseY BrIndentRegular $ docPar + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + consDoc + , -- data + -- Show a => + -- D + -- = forall a + -- . Show a => + -- D a + -- This alternative is only for -XDatatypeContexts. + -- But I think it is rather unlikely this will trigger without + -- -XDataTypeContexts, especially with the `docNonBottomSpacing` + -- above, so while not strictly necessary, this should not + -- hurt. + docAddBaseY BrIndentRegular $ docPar + (docLitS "data") + ( docLines + [ lhsContextDoc + , docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLit nameStr + , tyVarLine + ] + , consDoc + ] + ) + ] + _ -> briDocByExactNoComment ltycl + + _ -> briDocByExactNoComment ltycl + +createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered +createContextDoc [] = docEmpty +createContextDoc [t] = + docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] +createContextDoc (t1 : tR) = do + t1Doc <- docSharedWrapper layoutType t1 + tRDocs <- tR `forM` docSharedWrapper layoutType + docAlt + [ docSeq + [ docLitS "(" + , docForceSingleline $ docSeq $ List.intersperse docCommaSep + (t1Doc : tRDocs) + , docLitS ") =>" + , docSeparator + ] + , docLines $ join + [ [docSeq [docLitS "(", docSeparator, t1Doc]] + , tRDocs + <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , [docLitS ") =>", docSeparator] + ] + ] + +createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered +createBndrDoc bs = do + tyVarDocs <- bs `forM` \case + (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar _ _ext lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] + +createDerivingPar + :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +createDerivingPar derivs mainDoc = do + case derivs of + (L _ []) -> mainDoc + (L _ types) -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc + <$> types + +derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = + if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in + docSeq + [ docDeriving + , docWrapNodePrior types $ lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docWrapNodeRest types + $ docSeq + $ List.intersperse docCommaSep + $ ts <&> \case + HsIB _ t -> layoutType t + , whenMoreThan1Type ")" + , rhsStrategy + ] + where + strategyLeftRight = \case + (L _ StockStrategy ) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) + lVia@(L _ (ViaStrategy viaTypes) ) -> + ( docEmpty + , case viaTypes of + HsIB _ext t -> docSeq + [ docWrapNode lVia $ docLitS " via" + , docSeparator + , layoutType t + ] + ) + +docDeriving :: ToBriDocM BriDocNumbered +docDeriving = docLitS "deriving" + +createDetailsDoc + :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) +createDetailsDoc consNameStr details = case details of + PrefixCon args -> do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + singleLine = docSeq + [ docLit consNameStr + , docSeparator + , docForceSingleline + $ docSeq + $ List.intersperse docSeparator + $ fmap hsScaledThing args <&> layoutType + ] + leftIndented = docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType <$> fmap hsScaledThing args + multiAppended = docSeq + [ docLit consNameStr + , docSeparator + , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args + ] + multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + (docLit consNameStr) + (docLines $ layoutType <$> fmap hsScaledThing args) + case indentPolicy of + IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] + IndentPolicyFree -> + docAlt [singleLine, multiAppended, multiIndented, leftIndented] + RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_:_)) -> do + let ((fName1, fType1) : fDocR) = mkFieldDocs fields + -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + let allowSingleline = False + docAddBaseY BrIndentRegular + $ runFilteredAlternative + $ do + -- single-line: { i :: Int, b :: Bool } + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR + ] + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName + , docSeq [docLitS "::", docSeparator] + , docForceSingleline fType + ] + , docSeq + [ docLitS "," + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName + (docSeq [docLitS "::", docSeparator, fType]) + ] + ] + , docLitS "}" + ] + ) + InfixCon arg1 arg2 -> docSeq + [ layoutType $ hsScaledThing arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType $ hsScaledThing arg2 + ] + where + mkFieldDocs + :: [LConDeclField GhcPs] + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + mkFieldDocs = fmap $ \lField -> case lField of + L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t + +createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = Just $ docSeq + [docLitS "forall ", createBndrDoc lhsTyVarBndrs] + +createNamesAndTypeDoc + :: Data.Data.Data ast + => Located ast + -> [GenLocated t (FieldOcc GhcPs)] + -> Located (HsType GhcPs) + -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) +createNamesAndTypeDoc lField names t = + ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \case + L _ (FieldOcc _ fieldName) -> + docLit =<< lrdrNameToTextAnn fieldName + ] + , docWrapNodeRest lField $ layoutType t + ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -0,0 +1,975 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.Brittany.Internal.Layouters.Decl where + +import qualified Data.Data +import qualified Data.Foldable +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC.Data.Bag (bagToList, emptyBag) +import qualified GHC.Data.FastString as FastString +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic + ( Activation(..) + , InlinePragma(..) + , InlineSpec(..) + , LexicalFixity(..) + , RuleMatchInfo(..) + ) +import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.DataDecl +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint + + + +layoutDecl :: ToBriDoc HsDecl +layoutDecl d@(L loc decl) = case decl of + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + InstD _ (TyFamInstD _ tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False d tfid + InstD _ (ClsInstD _ inst) -> + withTransformedAnns d $ layoutClsInst (L loc inst) + _ -> briDocByExactNoComment d + +-------------------------------------------------------------------------------- +-- Sig +-------------------------------------------------------------------------------- + +layoutSig :: ToBriDoc Sig +layoutSig lsig@(L _loc sig) = case sig of + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ + InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> + docWrapNode lsig $ do + nameStr <- lrdrNameToTextAnn name + specStr <- specStringCompat lsig spec + let phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " + docLit + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + <> nameStr + <> Text.pack " #-}" + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ + PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ + _ -> briDocByExactNoComment lsig -- TODO + where + layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do + let keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] + nameStrs <- names `forM` lrdrNameToTextAnn + let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsBelow lsig + shouldBeHanging <- mAsk + <&> _conf_layout + .> _lconfig_hangingTypeSignature + .> confUnpack + if shouldBeHanging + then docSeq $ + [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ] + ] + else layoutLhsAndType + hasComments + (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) + "::" + typeDoc + +specStringCompat + :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String +specStringCompat ast = \case + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " + +layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) +layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of + BodyStmt _ body _ _ -> layoutExpr body + BindStmt _ lPat expr -> do + patDoc <- docSharedWrapper layoutPat lPat + expDoc <- docSharedWrapper layoutExpr expr + docCols ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO + + +-------------------------------------------------------------------------------- +-- HsBind +-------------------------------------------------------------------------------- + +layoutBind + :: ToBriDocC + (HsBindLR GhcPs GhcPs) + (Either [BriDocNumbered] BriDocNumbered) +layoutBind lbind@(L _ bind) = case bind of + FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" + funcPatDocs <- + docWrapNode lbind + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches + return $ Left $ funcPatDocs + PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do + patDocs <- colsWrapPat =<< layoutPat pat + clauseDocs <- layoutGrhs `mapM` grhss + mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? + binderDoc <- docLit $ Text.pack "=" + hasComments <- hasAnyCommentsBelow lbind + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereArg + hasComments + PatSynBind _ (PSB _ patID lpat rpat dir) -> do + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID + lpat + dir + rpat + _ -> Right <$> unknownNodeError "" lbind +layoutIPBind :: ToBriDoc IPBind +layoutIPBind lipbind@(L _ bind) = case bind of + IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" + IPBind _ (Left (L _ (HsIPName name))) expr -> do + ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name + binderDoc <- docLit $ Text.pack "=" + exprDoc <- layoutExpr expr + hasComments <- hasAnyCommentsBelow lipbind + layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments + + +data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) + | BagSig (LSig GhcPs) + +bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan +bindOrSigtoSrcSpan (BagBind (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l + +layoutLocalBinds + :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) +layoutLocalBinds lbinds@(L _ binds) = case binds of + -- HsValBinds (ValBindsIn lhsBindsLR []) -> + -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering + -- x@(HsValBinds (ValBindsIn{})) -> + -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x + HsValBinds _ (ValBinds _ bindlrs sigs) -> do + let unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + docs <- docWrapNode lbinds $ join <$> ordered `forM` \case + BagBind b -> either id return <$> layoutBind b + BagSig s -> return <$> layoutSig s + return $ Just $ docs +-- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> + HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" + HsIPBinds _ (IPBinds _ bb) -> + Just <$> mapM layoutIPBind bb + EmptyLocalBinds{} -> return $ Nothing + +-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is +-- parSpacing stuff.B +layoutGrhs + :: LGRHS GhcPs (LHsExpr GhcPs) + -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) +layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do + guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards + bodyDoc <- layoutExpr body + return (guardDocs, bodyDoc, body) + +layoutPatternBind + :: Maybe Text + -> BriDocNumbered + -> LMatch GhcPs (LHsExpr GhcPs) + -> ToBriDocM BriDocNumbered +layoutPatternBind funId binderDoc lmatch@(L _ match) = do + let pats = m_pats match + let (GRHSs _ grhss whereBinds) = m_grhss match + patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + let isInfix = isInfixMatch match + mIdStr <- case match of + Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId + _ -> pure Nothing + let mIdStr' = fixPatternBindIdentifier match <$> mIdStr + patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of + (Just idStr, p1:p2:pr) | isInfix -> if null pr + then + docCols ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else + docCols ColPatternsFuncInfix + ( [docCols ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR + ] + ] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) + (Just idStr, []) -> docLit idStr + (Just idStr, ps) -> + docCols ColPatternsFuncPrefix + $ appSep (docLit $ idStr) + : (spacifyDocs $ docForceSingleline <$> ps) + (Nothing, ps) -> + docCols ColPatterns + $ (List.intersperse docSeparator $ docForceSingleline <$> ps) + clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss + mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) + let alignmentToken = if null pats then Nothing else funId + hasComments <- hasAnyCommentsBelow lmatch + layoutPatternBindFinal alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereArg + hasComments + +fixPatternBindIdentifier + :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier match idStr = go $ m_ctxt match + where + go = \case + (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr + (FunRhs _ _ NoSrcStrict) -> idStr + (StmtCtxt ctx1 ) -> goInner ctx1 + _ -> idStr + -- I have really no idea if this path ever occurs, but better safe than + -- risking another "drop bangpatterns" bugs. + goInner = \case + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 + (TransStmtCtxt ctx1) -> goInner ctx1 + _ -> idStr + +layoutPatternBindFinal + :: Maybe Text + -> BriDocNumbered + -> Maybe BriDocNumbered + -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] + -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) + -- ^ AnnKey for the node that contains the AnnWhere position annotation + -> Bool + -> ToBriDocM BriDocNumbered +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do + let patPartInline = case mPatDoc of + Nothing -> [] + Just patDoc -> [appSep $ docForceSingleline $ return patDoc] + patPartParWrap = case mPatDoc of + Nothing -> id + Just patDoc -> docPar (return patDoc) + whereIndent <- do + shouldSpecial <- mAsk + <&> _conf_layout + .> _lconfig_indentWhereSpecial + .> confUnpack + regularIndentAmount <- mAsk + <&> _conf_layout + .> _lconfig_indentAmount + .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + [ docEnsureIndent BrIndentRegular + $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ return w + ] + ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty + [g] -> docSeq + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + gs -> docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ (List.intersperse docCommaSep + (docForceSingleline . return <$> gs) + ) + wherePart = case mWhereDocs of + Nothing -> Just docEmpty + Just (_, [w]) -> Just $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> Nothing + + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack + + runFilteredAlternative $ do + + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' + ] + ] + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine + + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` + + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1:gr) -> + ( docSeq [appSep $ docLit $ Text.pack "|", return g1] + : ( gr + <&> \g -> + docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + +-- | Layout a pattern synonym binding +layoutPatSynBind + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> HsPatSynDir GhcPs + -> LPat GhcPs + -> ToBriDocM BriDocNumbered +layoutPatSynBind name patSynDetails patDir rpat = do + let patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" + mWhereDocs <- layoutPatSynWhere patDir + headDoc <- fmap pure $ docSeq $ + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] + runFilteredAlternative $ do + addAlternative $ + -- pattern .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docSeq + ( [headDoc, docSeparator, body] + ++ case mWhereDocs of + Just ds -> [docSeparator, docPar whereDoc (docLines ds)] + Nothing -> [] + ) + addAlternative $ + -- pattern .. = + -- .. + -- pattern .. <- + -- .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) + ) + +-- | Helper method for the left hand side of a pattern synonym +layoutLPatSyn + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> ToBriDocM BriDocNumbered +layoutLPatSyn name (PrefixCon vars) = do + docName <- lrdrNameToTextAnn name + names <- mapM lrdrNameToTextAnn vars + docSeq . fmap appSep $ docLit docName : (docLit <$> names) +layoutLPatSyn name (InfixCon left right) = do + leftDoc <- lrdrNameToTextAnn left + docName <- lrdrNameToTextAnn name + rightDoc <- lrdrNameToTextAnn right + docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] +layoutLPatSyn name (RecCon recArgs) = do + docName <- lrdrNameToTextAnn name + args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs + docSeq . fmap docLit + $ [docName, Text.pack " { " ] + <> intersperse (Text.pack ", ") args + <> [Text.pack " }"] + +-- | Helper method to get the where clause from of explicitly bidirectional +-- pattern synonyms +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere hs = case hs of + ExplicitBidirectional (MG _ (L _ lbinds) _) -> do + binderDoc <- docLit $ Text.pack "=" + Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + _ -> pure Nothing + +-------------------------------------------------------------------------------- +-- TyClDecl +-------------------------------------------------------------------------------- + +layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl ltycl@(L _loc tycl) = case tycl of + SynDecl _ name vars fixity typ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True + -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + -- let parenWrapper = if hasTrailingParen + -- then appSep . docWrapNodeRest ltycl + -- else id + let wrapNodeRest = docWrapNodeRest ltycl + docWrapNodePrior ltycl + $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ + DataDecl _ext name tyVars _ dataDefn -> + layoutDataDecl ltycl name tyVars dataDefn + _ -> briDocByExactNoComment ltycl + +layoutSynDecl + :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Located (IdP GhcPs) + -> [LHsTyVarBndr () GhcPs] + -> LHsType GhcPs + -> ToBriDocM BriDocNumbered +layoutSynDecl isInfix wrapNodeRest name vars typ = do + nameStr <- lrdrNameToTextAnn name + let + lhs = appSep . wrapNodeRest $ if isInfix + then do + let (a : b : rest) = vars + hasOwnParens <- hasAnnKeywordComment a AnnOpenP + -- This isn't quite right, but does give syntactically valid results + let needsParens = not (null rest) || hasOwnParens + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + ] + ++ [ docParenL | needsParens ] + ++ [ layoutTyVarBndr False a + , docSeparator + , docLit nameStr + , docSeparator + , layoutTyVarBndr False b + ] + ++ [ docParenR | needsParens ] + ++ fmap (layoutTyVarBndr True) rest + else + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] + ++ fmap (layoutTyVarBndr True) vars + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsConnected typ + layoutLhsAndType hasComments sharedLhs "=" typeDoc + +layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) +layoutTyVarBndr needsSep lbndr@(L _ bndr) = do + docWrapNodePrior lbndr $ case bndr of + UserTyVar _ _ name -> do + nameStr <- lrdrNameToTextAnn name + docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] + KindedTyVar _ _ name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsSep ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] + + +-------------------------------------------------------------------------------- +-- TyFamInstDecl +-------------------------------------------------------------------------------- + + + +layoutTyFamInstDecl + :: Data.Data.Data a + => Bool + -> Located a + -> TyFamInstDecl GhcPs + -> ToBriDocM BriDocNumbered +layoutTyFamInstDecl inClass outerNode tfid = do + let + FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid + -- bndrsMay isJust e.g. with + -- type instance forall a . MyType (Maybe a) = Either () a + innerNode = outerNode + docWrapNodePrior outerNode $ do + nameStr <- lrdrNameToTextAnn name + needsParens <- hasAnnKeyword outerNode AnnOpenP + let + instanceDoc = if inClass + then docLit $ Text.pack "type" + else docSeq + [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] + makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered + makeForallDoc bndrs = do + bndrDocs <- layoutTyVarBndrs bndrs + docSeq + ( [docLit (Text.pack "forall")] + ++ processTyVarBndrsSingleline bndrDocs + ) + lhs = + docWrapNode innerNode + . docSeq + $ [appSep instanceDoc] + ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] + ++ [ docParenL | needsParens ] + ++ [appSep $ docWrapNode name $ docLit nameStr] + ++ intersperse docSeparator (layoutHsTyPats pats) + ++ [ docParenR | needsParens ] + hasComments <- (||) + <$> hasAnyRegularCommentsConnected outerNode + <*> hasAnyRegularCommentsRest innerNode + typeDoc <- docSharedWrapper layoutType typ + layoutLhsAndType hasComments lhs "=" typeDoc + + +layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats pats = pats <&> \case + HsValArg tm -> layoutType tm + HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] + -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change + -- is a bit strange. Hopefully this does not ignore any important + -- annotations. + HsArgPar _l -> error "brittany internal error: HsArgPar{}" + +-------------------------------------------------------------------------------- +-- ClsInstDecl +-------------------------------------------------------------------------------- + +-- | Layout an @instance@ declaration +-- +-- Layout signatures and bindings using the corresponding layouters from the +-- top-level. Layout the instance head, type family instances, and data family +-- instances using ExactPrint. +layoutClsInst :: ToBriDoc ClsInstDecl +layoutClsInst lcid@(L _ cid) = docLines + [ layoutInstanceHead + , docEnsureIndent BrIndentRegular + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) + ] + where + layoutInstanceHead :: ToBriDocM BriDocNumbered + layoutInstanceHead = + briDocByExactNoComment + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren + <$> lcid + + removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs + removeChildren c = c + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] + , cid_datafam_insts = [] + } + + -- | Like 'docLines', but sorts the lines based on location + docSortedLines + :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered + docSortedLines l = + allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l + + layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) + layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig + + layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) + layoutAndLocateBind lbind@(L loc _) = + L loc <$> (joinBinds =<< layoutBind lbind) + + joinBinds + :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered + joinBinds = \case + Left ns -> docLines $ return <$> ns + Right n -> return n + + layoutAndLocateTyFamInsts + :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateTyFamInsts ltfid@(L loc tfid) = + L loc <$> layoutTyFamInstDecl True ltfid tfid + + layoutAndLocateDataFamInsts + :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateDataFamInsts ldfid@(L loc _) = + L loc <$> layoutDataFamInstDecl ldfid + + -- | Send to ExactPrint then remove unecessary whitespace + layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl + layoutDataFamInstDecl ldfid = + fmap stripWhitespace <$> briDocByExactNoComment ldfid + + -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations + stripWhitespace :: BriDocF f -> BriDocF f + stripWhitespace (BDFExternal ann anns b t) = + BDFExternal ann anns b $ stripWhitespace' t + stripWhitespace b = b + + -- | This fixes two issues of output coming from Exactprinting + -- associated (data) type decls. Firstly we place the output into docLines, + -- so one newline coming from Exactprint is superfluous, so we drop the + -- first (empty) line. The second issue is Exactprint indents the first + -- member in a strange fashion: + -- + -- input: + -- + -- > instance MyClass Int where + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- output of just exactprinting the associated data type syntax node + -- + -- > + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- To fix this, we strip whitespace from the start of the comments and the + -- first line of the declaration, stopping when we see "data" or "type" at + -- the start of a line. I.e., this function yields + -- + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- Downside apart from being a hacky and brittle fix is that this removes + -- possible additional indentation from comments before the first member. + -- + -- But the whole thing is just a temporary measure until brittany learns + -- to layout data/type decls. + stripWhitespace' :: Text -> Text + stripWhitespace' t = + Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t + where + go [] = [] + go (line1 : lineR) = case Text.stripStart line1 of + st | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR + isTypeOrData t' = + (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "newtype" `Text.isPrefixOf` t') + || (Text.pack "data" `Text.isPrefixOf` t') + + +-------------------------------------------------------------------------------- +-- Common Helpers +-------------------------------------------------------------------------------- + +layoutLhsAndType + :: Bool + -> ToBriDocM BriDocNumbered + -> String + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +layoutLhsAndType hasComments lhs sep typeDoc = do + runFilteredAlternative $ do + -- (separators probably are "=" or "::") + -- lhs = type + -- lhs :: type + addAlternativeCond (not hasComments) $ docSeq + [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] + -- lhs + -- :: typeA + -- -> typeB + -- lhs + -- = typeA + -- -> typeB + addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols + ColTyOpPrefix + [ appSep $ docLitS sep + , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc + ] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -0,0 +1,1078 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.Expr where + +import qualified Data.Data +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) +import qualified GHC.Data.FastString as FastString +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Types.Name +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + + + +layoutExpr :: ToBriDoc HsExpr +layoutExpr lexpr@(L _ expr) = do + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack + let allowFreeIndent = indentPolicy == IndentPolicyFree + docWrapNode lexpr $ case expr of + HsVar _ vname -> do + docLit =<< lrdrNameToTextAnn vname + HsUnboundVar _ oname -> + docLit $ Text.pack $ occNameString oname + HsRecFld{} -> do + -- TODO + briDocByExactInlineOnly "HsRecFld" lexpr + HsOverLabel _ext _reboundFromLabel name -> + let label = FastString.unpackFS name + in docLit . Text.pack $ '#' : label + HsIPVar _ext (HsIPName name) -> + let label = FastString.unpackFS name + in docLit . Text.pack $ '?' : label + HsOverLit _ olit -> do + allocateNode $ overLitValBriDoc $ ol_val olit + HsLit _ lit -> do + allocateNode $ litBriDoc lit + HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds {} <- llocals + , L _ (GRHS _ [] body) <- lgrhs + -> do + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let shouldPrefixSeparator = case p of + L _ LazyPat{} -> isFirst + L _ BangPat{} -> isFirst + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let funcPatternPartLine = + docCols ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing + $ docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> + unknownNodeError "HsLam too complex" lexpr + HsLamCase _ (MG _ (L _ []) _) -> do + docSetParSpacing $ docAddBaseY BrIndentRegular $ + (docLit $ Text.pack "\\case {}") + HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "\\case") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + HsApp _ exp1@(L _ HsApp{}) exp2 -> do + let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) + gather list = \case + L _ (HsApp _ l r) -> gather (r:list) l + x -> (x, list) + let (headE, paramEs) = gather [exp2] exp1 + let colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq + headDoc <- docSharedWrapper layoutExpr headE + paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs + hasComments <- hasAnyCommentsConnected exp2 + runFilteredAlternative $ do + -- foo x y + addAlternativeCond (not hasComments) + $ colsOrSequence + $ appSep (docForceSingleline headDoc) + : spacifyDocs (docForceSingleline <$> paramDocs) + -- foo x + -- y + addAlternativeCond allowFreeIndent + $ docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY + $ docAddBaseY BrIndentRegular + $ docLines + $ docForceSingleline <$> paramDocs + ] + -- foo + -- x + -- y + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docForceSingleline headDoc) + ( docNonBottomSpacing + $ docLines paramDocs + ) + -- ( multi + -- line + -- function + -- ) + -- x + -- y + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + headDoc + ( docNonBottomSpacing + $ docLines paramDocs + ) + HsApp _ exp1 exp2 -> do + -- TODO: if expDoc1 is some literal, we may want to create a docCols here. + expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc2 <- docSharedWrapper layoutExpr exp2 + docAlt + [ -- func arg + docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + , -- func argline1 + -- arglines + -- e.g. + -- func Abc + -- { member1 = True + -- , member2 = 13 + -- } + docSetParSpacing -- this is most likely superfluous because + -- this is a sequence of a one-line and a par-space + -- anyways, so it is _always_ par-spaced. + $ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docForceSingleline expDoc1 + , docForceParSpacing expDoc2 + ] + , -- func + -- arg + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docForceSingleline expDoc1) + (docNonBottomSpacing expDoc2) + , -- fu + -- nc + -- ar + -- gument + docAddBaseY BrIndentRegular + $ docPar + expDoc1 + expDoc2 + ] + HsAppType _ exp1 (HsWC _ ty1) -> do + t <- docSharedWrapper layoutType ty1 + e <- docSharedWrapper layoutExpr exp1 + docAlt + [ docSeq + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar + e + (docSeq [docLit $ Text.pack "@", t ]) + ] + OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do + let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) + gather opExprList = \case + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft + leftOperandDoc <- docSharedWrapper layoutExpr leftOperand + appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight + allowSinglelinePar <- do + hasComLeft <- hasAnyCommentsConnected expLeft + hasComOp <- hasAnyCommentsConnected expOp + pure $ not hasComLeft && not hasComOp + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + runFilteredAlternative $ do + -- > one + two + three + -- or + -- > one + two + case x of + -- > _ -> three + addAlternativeCond allowSinglelinePar + $ docSeq + [ appSep $ docForceSingleline leftOperandDoc + , docSeq + $ appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc + ] + -- this case rather leads to some unfortunate layouting than to anything + -- useful; disabling for now. (it interfers with cols stuff.) + -- addAlternative + -- $ docSetBaseY + -- $ docPar + -- leftOperandDoc + -- ( docLines + -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + -- ) + -- > one + -- > + two + -- > + three + addAlternative $ + docPar + leftOperandDoc + ( docLines + $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) + OpApp _ expLeft expOp expRight -> do + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp + expDocRight <- docSharedWrapper layoutExpr expRight + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False + runFilteredAlternative $ do + -- one-line + addAlternative + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceSingleline expDocRight + ] + -- -- line + freely indented block for right expression + -- addAlternative + -- $ docSeq + -- [ appSep $ docForceSingleline expDocLeft + -- , appSep $ docForceSingleline expDocOp + -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight + -- ] + -- two-line + addAlternative $ do + let + expDocOpAndRight = docForceSingleline + $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight + -- TODO: in both cases, we don't force expDocLeft to be + -- single-line, which has certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. + -- one-line + par + addAlternativeCond allowPar + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceParSpacing expDocRight + ] + -- more lines + addAlternative $ do + let expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight + NegApp _ op _ -> do + opDoc <- docSharedWrapper layoutExpr op + docSeq [ docLit $ Text.pack "-" + , opDoc + ] + HsPar _ innerExp -> do + innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp + docAlt + [ docSeq + [ docLit $ Text.pack "(" + , docForceSingleline innerExpDoc + , docLit $ Text.pack ")" + ] + , docSetBaseY $ docLines + [ docCols ColOpPrefix + [ docLit $ Text.pack "(" + , docAddBaseY (BrIndentSpecial 2) innerExpDoc + ] + , docLit $ Text.pack ")" + ] + ] + SectionL _ left op -> do -- TODO: add to testsuite + leftDoc <- docSharedWrapper layoutExpr left + opDoc <- docSharedWrapper layoutExpr op + docSeq [leftDoc, docSeparator, opDoc] + SectionR _ op right -> do -- TODO: add to testsuite + opDoc <- docSharedWrapper layoutExpr op + rightDoc <- docSharedWrapper layoutExpr right + docSeq [opDoc, docSeparator, rightDoc] + ExplicitTuple _ args boxity -> do + let argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e); + (L _ (Missing NoExtField)) -> (arg, Nothing) + argDocs <- forM argExprs + $ docSharedWrapper + $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM + hasComments <- orM + ( hasCommentsBetween lexpr AnnOpenP AnnCloseP + : map hasAnyCommentsBelow args + ) + let (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) + case splitFirstLast argDocs of + FirstLastEmpty -> docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) closeLit + ] + FirstLastSingleton e -> docAlt + [ docCols ColTuple + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + , closeLit + ] + , docSetBaseY $ docLines + [ docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + ] + , closeLit + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] + ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) + ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + addAlternative $ + let + start = docCols ColTuples + [appSep openLit, e1] + linesM = ems <&> \d -> + docCols ColTuples [docCommaSep, d] + lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + HsCase _ cExp (MG _ (L _ []) _) -> do + cExpDoc <- docSharedWrapper layoutExpr cExp + docAlt + [ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") + ] + HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do + cExpDoc <- docSharedWrapper layoutExpr cExp + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches + docAlt + [ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of" + ]) + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "of") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + ) + ] + HsIf _ ifExpr thenExpr elseExpr -> do + ifExprDoc <- docSharedWrapper layoutExpr ifExpr + thenExprDoc <- docSharedWrapper layoutExpr thenExpr + elseExprDoc <- docSharedWrapper layoutExpr elseExpr + hasComments <- hasAnyCommentsBelow lexpr + let maySpecialIndent = + case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 + -- TODO: some of the alternatives (especially last and last-but-one) + -- overlap. + docSetIndentLevel $ runFilteredAlternative $ do + -- if _ then _ else _ + addAlternativeCond (not hasComments) + $ docSeq + [ appSep $ docLit $ Text.pack "if" + , appSep $ docForceSingleline ifExprDoc + , appSep $ docLit $ Text.pack "then" + , appSep $ docForceSingleline thenExprDoc + , appSep $ docLit $ Text.pack "else" + , docForceSingleline elseExprDoc + ] + -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docNonBottomSpacing $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docNonBottomSpacing $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + -- either + -- if multi + -- line + -- condition + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if multi + -- line + -- condition + -- then + -- stuff + -- else + -- stuff + -- note that this does _not_ have par-spacing + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + addAlternative + $ docSetBaseY + $ docLines + [ docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + HsMultiIf _ cases -> do + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" + hasComments <- hasAnyCommentsBelow lexpr + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "if") + (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) + HsLet _ binds exp1 -> do + expDoc1 <- docSharedWrapper layoutExpr exp1 + -- We jump through some ugly hoops here to ensure proper sharing. + hasComments <- hasAnyCommentsBelow lexpr + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds + let + ifIndentFreeElse :: a -> a -> a + ifIndentFreeElse x y = + case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x + -- this `docSetBaseAndIndent` might seem out of place (especially the + -- Indent part; setBase is necessary due to the use of docLines below), + -- but is here due to ghc-exactprint's DP handling of "let" in + -- particular. + -- Just pushing another indentation level is a straightforward approach + -- to making brittany idempotent, even though the result is non-optimal + -- if "let" is moved horizontally as part of the transformation, as the + -- comments before the first let item are moved horizontally with it. + docSetBaseAndIndent $ case mBindDocs of + Just [bindDoc] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ appSep $ docLit $ Text.pack "let" + , docNodeAnnKW lexpr (Just AnnLet) + $ appSep $ docForceSingleline bindDoc + , appSep $ docLit $ Text.pack "in" + , docForceSingleline expDoc1 + ] + addAlternative $ docLines + [ docNodeAnnKW lexpr (Just AnnLet) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) + ] + , docAlt + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY expDoc1) + ] + ] + Just bindDocs@(_:_) -> runFilteredAlternative $ do + --either + -- let + -- a = b + -- c = d + -- in foo + -- bar + -- baz + --or + -- let + -- a = b + -- c = d + -- in + -- fooooooooooooooooooo + let noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular + $ docForceParSpacing expDoc1 + ] + ] + addAlternative $ case indentPolicy of + IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyMultiple -> docLines noHangingBinds + IndentPolicyFree -> docLines + [ docNodeAnnKW lexpr (Just AnnLet) + $ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines bindDocs + ] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY expDoc1 + ] + ] + addAlternative + $ docLines + [ docNodeAnnKW lexpr (Just AnnLet) + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] + _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] + -- docSeq [appSep $ docLit "let in", expDoc1] + HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of + DoExpr _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + MDoExpr _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ docNodeAnnKW lexpr Nothing + $ appSep + $ docLit + $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq $ List.intersperse docCommaSep + $ docForceSingleline <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative $ + let + start = docCols ColListComp + [ docNodeAnnKW lexpr Nothing + $ appSep $ docLit $ Text.pack "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1:sM) = List.init stmtDocs + line1 = docCols ColListComp + [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + _ -> do + -- TODO + unknownNodeError "HsDo{} unknown stmtCtx" lexpr + ExplicitList _ _ elems@(_:_) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr + hasComments <- hasAnyCommentsBelow lexpr + case splitFirstLast elemDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "[" + , docSeparator + , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e + ] + , docLit $ Text.pack "]" + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) + ++ [docLit $ Text.pack "]"] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> + docCols ColList [docCommaSep, d] + lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ExplicitList _ _ [] -> + docLit $ Text.pack "[]" + RecordCon _ lname fields -> + case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- fs + `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression False indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just (L _ 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return (fieldl, lrdrNameToText lnameF, fExpDoc) + recordExpression True indentPolicy lexpr nameDoc fieldDocs + _ -> unknownNodeError "RecordCon with puns" lexpr + RecordUpd _ rExpr fields -> do + rExprDoc <- docSharedWrapper layoutExpr rExpr + rFs <- fields + `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ case ambName of + Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + recordExpression False indentPolicy lexpr rExprDoc rFs + ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do + expDoc <- docSharedWrapper layoutExpr exp1 + typDoc <- docSharedWrapper layoutType typ1 + docSeq + [ appSep expDoc + , appSep $ docLit $ Text.pack "::" + , typDoc + ] + ArithSeq _ Nothing info -> + case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> + briDocByExactInlineOnly "ArithSeq" lexpr + HsBracket{} -> do + -- TODO + briDocByExactInlineOnly "HsBracket{}" lexpr + HsRnBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsRnBracketOut{}" lexpr + HsTcBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsTcBracketOut{}" lexpr + HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do + allocateNode $ BDFPlain + (Text.pack + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]") + HsSpliceE{} -> do + -- TODO + briDocByExactInlineOnly "HsSpliceE{}" lexpr + HsProc{} -> do + -- TODO + briDocByExactInlineOnly "HsProc{}" lexpr + HsStatic{} -> do + -- TODO + briDocByExactInlineOnly "HsStatic{}" lexpr + HsTick{} -> do + -- TODO + briDocByExactInlineOnly "HsTick{}" lexpr + HsBinTick{} -> do + -- TODO + briDocByExactInlineOnly "HsBinTick{}" lexpr + HsConLikeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsWrap{}" lexpr + ExplicitSum{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitSum{}" lexpr + HsPragE{} -> do + -- TODO + briDocByExactInlineOnly "HsPragE{}" lexpr + +recordExpression + :: (Data.Data.Data lExpr, Data.Data.Data name) + => Bool + -> IndentPolicy + -> GenLocated SrcSpan lExpr + -> ToBriDocM BriDocNumbered + -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] + -> ToBriDocM BriDocNumbered +recordExpression False _ lexpr nameDoc [] = + docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression True _ lexpr nameDoc [] = + docSeq -- this case might still be incomplete, and is probably not used + -- atm anyway. + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do + let (rF1f, rF1n, rF1e) = rF1 + runFilteredAlternative $ do + -- container { fieldA = blub, fieldB = blub } + addAlternative + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc + , appSep $ docLit $ Text.pack "{" + , docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , if dotdot + then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator + , docLit $ Text.pack "}" + ] + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + dotdotLine = if dotdot + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing $ docLines $ let + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq [ appSep $ docLit $ Text.pack "=" + , docForceParSpacing x + ] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + dotdotLine = if dotdot + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ) + +litBriDoc :: HsLit GhcPs -> BriDocFInt +litBriDoc = \case + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + _ -> error "litBriDoc: literal with no SourceText" + +overLitValBriDoc :: OverLitVal -> BriDocFInt +overLitValBriDoc = \case + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIsString (SourceText t) _ -> BDFLit $ Text.pack t + _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.Expr where + +import GHC.Hs +import Language.Haskell.Brittany.Internal.Types + + + +layoutExpr :: ToBriDoc HsExpr + +-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) + +litBriDoc :: HsLit GhcPs -> BriDocFInt + +overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.IE where + +import qualified Data.List.Extra +import qualified Data.Text as Text +import GHC + ( AnnKeywordId(..) + , GenLocated(L) + , Located + , ModuleName + , moduleNameString + , unLoc + ) +import GHC.Hs +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + + + +prepareName :: LIEWrappedName name -> Located name +prepareName = ieLWrappedName + +layoutIE :: ToBriDoc IE +layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of + IEVar _ x -> layoutWrapped lie x + IEThingAbs _ x -> layoutWrapped lie x + IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] + IEThingWith _ x (IEWildcard _) _ _ -> + docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] + IEThingWith _ x _ ns _ -> do + hasComments <- orM + ( hasCommentsBetween lie AnnOpenP AnnCloseP + : hasAnyCommentsBelow x + : map hasAnyCommentsBelow ns + ) + let sortedNs = List.sortOn wrappedNameToText ns + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [layoutWrapped lie x, docLit $ Text.pack "("] + ++ intersperse docCommaSep (map nameDoc sortedNs) + ++ [docParenR] + addAlternative + $ docWrapNodeRest lie + $ docAddBaseY BrIndentRegular + $ docPar + (layoutWrapped lie x) + (layoutItems (splitFirstLast sortedNs)) + where + nameDoc = docLit <=< lrdrNameToTextAnn . prepareName + layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] + layoutItems FirstLastEmpty = docSetBaseY $ docLines + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] + layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] + layoutItems (FirstLast n1 nMs nN) = + docSetBaseY + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + ++ map layoutItem nMs + ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] + IEModuleContents _ n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + where + layoutWrapped _ = \case + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEPattern n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "pattern " <> name + L _ (IEType n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "type " <> name + +data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted +-- Helper function to deal with Located lists of LIEs. +-- In particular this will also associate documentation +-- from the located list that actually belongs to the last IE. +-- It also adds docCommaSep to all but the first element +-- This configuration allows both vertical and horizontal +-- handling of the resulting list. Adding parens is +-- left to the caller since that is context sensitive +layoutAnnAndSepLLIEs + :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do + let makeIENode ie = docSeq [docCommaSep, ie] + let sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText + $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies + ieCommaDocs <- + docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of + FirstLastEmpty -> [] + FirstLastSingleton ie -> [ie] + FirstLast ie1 ieMs ieN -> + [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] + pure $ fmap pure ieCommaDocs -- returned shared nodes + where + mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] + mergeGroup [] = [] + mergeGroup items@[_] = items + mergeGroup items = if + | all isProperIEThing items -> [List.foldl1' thingFolder items] + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items + -- proper means that if it is a ThingWith, it does not contain a wildcard + -- (because I don't know what a wildcard means if it is not already a + -- IEThingAll). + isProperIEThing :: LIE GhcPs -> Bool + isProperIEThing = \case + L _ (IEThingAbs _ _wn) -> True + L _ (IEThingAll _ _wn) -> True + L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True + _ -> False + isIEVar :: LIE GhcPs -> Bool + isIEVar = \case + L _ IEVar{} -> True + _ -> False + thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs + thingFolder l1@(L _ IEVar{} ) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 ( L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) + = L + l + (IEThingWith x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) + ) + thingFolder _ _ = + error "thingFolder should be exhaustive because we have a guard above" + + +-- Builds a complete layout for the given located +-- list of LIEs. The layout provides two alternatives: +-- (item, item, ..., item) +-- ( item +-- , item +-- ... +-- , item +-- ) +-- If the llies contains comments the list will +-- always expand over multiple lines, even when empty: +-- () -- no comments +-- ( -- a comment +-- ) +layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline shouldSort llies = do + ieDs <- layoutAnnAndSepLLIEs shouldSort llies + hasComments <- hasAnyCommentsBelow llies + runFilteredAlternative $ case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" + addAlternativeCond hasComments $ docPar + (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH : ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +wrappedNameToText :: LIEWrappedName RdrName -> Text +wrappedNameToText = \case + L _ (IEName n) -> lrdrNameToText n + L _ (IEPattern n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +lieToText :: LIE GhcPs -> Text +lieToText = \case + L _ (IEVar _ wn ) -> wrappedNameToText wn + L _ (IEThingAbs _ wn ) -> wrappedNameToText wn + L _ (IEThingAll _ wn ) -> wrappedNameToText wn + L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn + -- TODO: These _may_ appear in exports! + -- Need to check, and either put them at the top (for module) or do some + -- other clever thing. + L _ (IEModuleContents _ n) -> moduleNameToText n + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + where + moduleNameToText :: Located ModuleName -> Text + moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.Import where + +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (GenLocated(L), Located, moduleNameString, unLoc) +import GHC.Hs +import GHC.Types.Basic +import GHC.Unit.Types (IsBootInterface(..)) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types + + + +prepPkg :: SourceText -> String +prepPkg rawN = case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" +prepModName :: Located e -> e +prepModName = unLoc + +layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered +layoutImport importD = case importD of + ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do + importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + compact = indentPolicy /= IndentPolicyFree + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies + minQLength = length "import qualified " + qLengthReal = + let qualifiedPart = if q /= NotQualified then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal + -- Cost in columns of importColumn + asCost = length "as " + hidingParenCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength + importQualifiers = docSeq + [ appSep $ docLit $ Text.pack "import" + , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } + , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty + , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty + , maybe docEmpty (appSep . docLit) pkgNameT + ] + indentName = + if compact then id else docEnsureIndent (BrIndentSpecial qLength) + modNameD = + indentName $ appSep $ docLit modNameT + hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 + hidDocColDiff = importCol - 2 - hidDocCol + hidDoc = if hiding + then appSep $ docLit $ Text.pack "hiding" + else docEmpty + importHead = docSeq [importQualifiers, modNameD] + bindingsD = case mllies of + Nothing -> docEmpty + Just (_, llies) -> do + hasComments <- hasAnyCommentsBelow llies + if compact + then docAlt + [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] + , let makeParIfHiding = if hiding + then docAddBaseY BrIndentRegular . docPar hidDoc + else id + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + ] + else do + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + ( docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) + makeAsDoc asT = + docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] + if compact + then + let asDoc = maybe docEmpty makeAsDoc masT + in docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular $ + docPar (docSeq [importHead, asDoc]) bindingsD + ] + else + case masT of + Just n -> if enoughRoom + then docLines + [ docSeq [importHead, asDoc], bindingsD] + else docLines [importHead, asDoc, bindingsD] + where + enoughRoom = nameCost < importAsCol - asCost + asDoc = + docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) + $ makeAsDoc n + Nothing -> if enoughRoom + then docSeq [importHead, bindingsD] + else docLines [importHead, bindingsD] + where enoughRoom = nameCost < importCol - hidingParenCost + _ -> docEmpty diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.Module where + +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) +import GHC.Hs +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types + (DeltaPos(..), commentContents, deltaRow) + + + +layoutModule :: ToBriDoc' HsModule +layoutModule lmod@(L _ mod') = case mod' of + -- Implicit module Main + HsModule _ Nothing _ imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) + -- sortedImports <- sortImports imports + -- docLines $ [layoutImport y i | (y, i) <- sortedImports] + HsModule _ (Just n) les imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + -- sortedImports <- sortImports imports + let tn = Text.pack $ moduleNameString $ unLoc n + allowSingleLineExportList <- mAsk + <&> _conf_layout + .> _lconfig_allowSingleLineExportList + .> confUnpack + -- the config should not prevent single-line layout when there is no + -- export list + let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les + docLines + $ docSeq + [ docNodeAnnKW lmod Nothing docEmpty + -- A pseudo node that serves merely to force documentation + -- before the node + , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do + addAlternativeCond allowSingleLine $ + docForceSingleline + $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + addAlternative + $ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docSeq [ + docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + ) + ] + ] + : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] + +data CommentedImport + = EmptyLine + | IndependentComment (Comment, DeltaPos) + | ImportStatement ImportStatementRecord + +instance Show CommentedImport where + show = \case + EmptyLine -> "EmptyLine" + IndependentComment _ -> "IndependentComment" + ImportStatement r -> + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +data ImportStatementRecord = ImportStatementRecord + { commentsBefore :: [(Comment, DeltaPos)] + , commentsAfter :: [(Comment, DeltaPos)] + , importStatement :: ImportDecl GhcPs + } + +instance Show ImportStatementRecord where + show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +transformToCommentedImport + :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] +transformToCommentedImport is = do + nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do + annotionMay <- astAnn i + pure (annotionMay, rawImport) + let + convertComment (c, DP (y, x)) = + replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] + accumF + :: [(Comment, DeltaPos)] + -> (Maybe Annotation, ImportDecl GhcPs) + -> ([(Comment, DeltaPos)], [CommentedImport]) + accumF accConnectedComm (annMay, decl) = case annMay of + Nothing -> + ( [] + , [ ImportStatement ImportStatementRecord { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } + ] + ) + Just ann -> + let + blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 + (newAccumulator, priorComments') = + List.span ((== 0) . deltaRow . snd) (annPriorComments ann) + go + :: [(Comment, DeltaPos)] + -> [(Comment, DeltaPos)] + -> ([CommentedImport], [(Comment, DeltaPos)], Int) + go acc [] = ([], acc, 0) + go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) + go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs + go acc ((c1, DP (y, x)) : xs) = + ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine + , (c1, DP (1, x)) : acc + , 0 + ) + (convertedIndependentComments, beforeComments, initialBlanks) = + if blanksBeforeImportDecl /= 0 + then (convertComment =<< priorComments', [], 0) + else go [] (reverse priorComments') + in + ( newAccumulator + , convertedIndependentComments + ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine + ++ [ ImportStatement ImportStatementRecord + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm + , importStatement = decl + } + ] + ) + let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations + pure $ join $ (convertComment =<< finalAcc) : finalList + +sortCommentedImports :: [CommentedImport] -> [CommentedImport] +sortCommentedImports = + unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify + where + unpackImports :: [CommentedImport] -> [CommentedImport] + unpackImports xs = xs >>= \case + l@EmptyLine -> [l] + l@IndependentComment{} -> [l] + ImportStatement r -> + map IndependentComment (commentsBefore r) ++ [ImportStatement r] + mergeGroups + :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] + mergeGroups xs = xs >>= \case + Left x -> [x] + Right y -> ImportStatement <$> y + sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] + sortGroups = + List.sortOn (moduleNameString . unLoc . ideclName . importStatement) + groupify + :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] + groupify cs = go [] cs + where + go [] = \case + (l@EmptyLine : rest) -> Left l : go [] rest + (l@IndependentComment{} : rest) -> Left l : go [] rest + (ImportStatement r : rest) -> go [r] rest + [] -> [] + go acc = \case + (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest + (l@IndependentComment{} : rest) -> + Left l : Right (reverse acc) : go [] rest + (ImportStatement r : rest) -> go (r : acc) rest + [] -> [Right (reverse acc)] + +commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered +commentedImportsToDoc = \case + EmptyLine -> docLitS "" + IndependentComment c -> commentToDoc c + ImportStatement r -> + docSeq + ( layoutImport (importStatement r) + : map commentToDoc (commentsAfter r) + ) + where + commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.Pattern where + +import qualified Data.Foldable as Foldable +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import GHC (GenLocated(L), ol_val) +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import Language.Haskell.Brittany.Internal.LayouterBasics +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types + + + +-- | layouts patterns (inside function bindings, case alternatives, let +-- bindings or do notation). E.g. for input +-- > case computation of +-- > (warnings, Success a b) -> .. +-- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by +-- 'layoutPat'. Similarly for +-- > func abc True 0 = [] +-- ^^^^^^^^^^ this part +-- We will use `case .. of` as the imagined prefix to the examples used in +-- the different cases below. +layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) +layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + -- _ -> expr + VarPat _ n -> + fmap Seq.singleton $ docLit $ lrdrNameToText n + -- abc -> expr + LitPat _ lit -> + fmap Seq.singleton $ allocateNode $ litBriDoc lit + -- 0 -> expr + ParPat _ inner -> do + -- (nestedpat) -> expr + left <- docLit $ Text.pack "(" + right <- docLit $ Text.pack ")" + innerDocs <- colsWrapPat =<< layoutPat inner + return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right + -- return $ (left Seq.<| innerDocs) Seq.|> right + -- case Seq.viewl innerDocs of + -- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur.. + -- x1 Seq.:< rest -> case Seq.viewr rest of + -- Seq.EmptyR -> + -- fmap return $ docSeq + -- [ docLit $ Text.pack "(" + -- , return x1 + -- , docLit $ Text.pack ")" + -- ] + -- middle Seq.:> xN -> do + -- x1' <- docSeq [docLit $ Text.pack "(", return x1] + -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] + -- return $ (x1' Seq.<| middle) Seq.|> xN' + ConPat _ lname (PrefixCon args) -> do + -- Abc a b c -> expr + nameDoc <- lrdrNameToTextAnn lname + argDocs <- layoutPat `mapM` args + if null argDocs + then return <$> docLit nameDoc + else do + x1 <- appSep (docLit nameDoc) + xR <- fmap Seq.fromList + $ sequence + $ spacifyDocs + $ fmap colsWrapPat argDocs + return $ x1 Seq.<| xR + ConPat _ lname (InfixCon left right) -> do + -- a :< b -> expr + nameDoc <- lrdrNameToTextAnn lname + leftDoc <- appSep . colsWrapPat =<< layoutPat left + rightDoc <- colsWrapPat =<< layoutPat right + middle <- appSep $ docLit nameDoc + return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc + ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do + -- Abc{} -> expr + let t = lrdrNameToText lname + fmap Seq.singleton $ docLit $ t <> Text.pack "{}" + ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + -- Abc { a = locA, b = locB, c = locC } -> expr1 + -- Abc { a, b, c } -> expr2 + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ List.intersperse docCommaSep + $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName + , docSeparator + , docLit $ Text.pack "}" + ] + ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do + -- Abc { .. } -> expr + let t = lrdrNameToText lname + Seq.singleton <$> docSeq + [ appSep $ docLit t + , docLit $ Text.pack "{..}" + ] + ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do + -- Abc { a = locA, .. } + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case + (fieldName, Just fieldDoc) -> + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + , docCommaSep + ] + (fieldName, Nothing) -> [docLit fieldName, docCommaSep] + , docLit $ Text.pack "..}" + ] + TuplePat _ args boxity -> do + -- (nestedpat1, nestedpat2, nestedpat3) -> expr + -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr + case boxity of + Boxed -> wrapPatListy args "()" docParenL docParenR + Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep + AsPat _ asName asPat -> do + -- bind@nestedpat -> expr + wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") + SigPat _ pat1 (HsPS _ ty1) -> do + -- i :: Int -> expr + patDocs <- layoutPat pat1 + tyDoc <- docSharedWrapper layoutType ty1 + case Seq.viewr patDocs of + Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" + xR Seq.:> xN -> do + xN' <- -- at the moment, we don't support splitting patterns into + -- multiple lines. but we cannot enforce pasting everything + -- into one line either, because the type signature will ignore + -- this if we overflow sufficiently. + -- In order to prevent syntactically invalid results in such + -- cases, we need the AddBaseY here. + -- This can all change when patterns get multiline support. + docAddBaseY BrIndentRegular $ docSeq + [ appSep $ return xN + , appSep $ docLit $ Text.pack "::" + , docForceSingleline tyDoc + ] + return $ xR Seq.|> xN' + ListPat _ elems -> + -- [] -> expr1 + -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 + wrapPatListy elems "[]" docBracketL docBracketR + BangPat _ pat1 -> do + -- !nestedpat -> expr + wrapPatPrepend pat1 (docLit $ Text.pack "!") + LazyPat _ pat1 -> do + -- ~nestedpat -> expr + wrapPatPrepend pat1 (docLit $ Text.pack "~") + NPat _ llit@(L _ ol) mNegative _ -> do + -- -13 -> expr + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol + negDoc <- docLit $ Text.pack "-" + pure $ case mNegative of + Just{} -> Seq.fromList [negDoc, litDoc] + Nothing -> Seq.singleton litDoc + + _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat + +colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered +colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList + +wrapPatPrepend + :: LPat GhcPs + -> ToBriDocM BriDocNumbered + -> ToBriDocM (Seq BriDocNumbered) +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR + +wrapPatListy + :: [LPat GhcPs] + -> String + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + -> ToBriDocM (Seq BriDocNumbered) +wrapPatListy elems both start end = do + elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) + case Seq.viewl elemDocs of + Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both + x1 Seq.:< rest -> do + sDoc <- start + eDoc <- end + rest' <- rest `forM` \bd -> docSeq + [ docCommaSep + , return bd + ] + return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.Brittany.Internal.Layouters.Stmt where + +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (GenLocated(L)) +import GHC.Hs +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types + + + +layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) +layoutStmt lstmt@(L _ stmt) = do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentAmount :: Int <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + docWrapNode lstmt $ case stmt of + LastStmt _ body Nothing _ -> do + layoutExpr body + BindStmt _ lPat expr -> do + patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat + expDoc <- docSharedWrapper layoutExpr expr + docAlt + [ docCols + ColBindStmt + [ appSep patDoc + , docSeq + [ appSep $ docLit $ Text.pack "<-" + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc + ] + ] + , docCols + ColBindStmt + [ appSep patDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "<-") (expDoc) + ] + ] + LetStmt _ binds -> do + let isFree = indentPolicy == IndentPolicyFree + let indentFourPlus = indentAmount >= 4 + layoutLocalBinds binds >>= \case + Nothing -> docLit $ Text.pack "let" + -- i just tested the above, and it is indeed allowed. heh. + Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [bindDoc] -> docAlt + [ -- let bind = expr + docCols + ColDoLet + [ appSep $ docLit $ Text.pack "let" + , let + f = case indentPolicy of + IndentPolicyFree -> docSetBaseAndIndent + IndentPolicyLeft -> docForceSingleline + IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc + ] + , -- let + -- bind = expr + docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) + ] + Just bindDocs -> runFilteredAlternative $ do + -- let aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (isFree || indentFourPlus) $ docSeq + [ appSep $ docLit $ Text.pack "let" + , let f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs + ] + -- let + -- aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (not indentFourPlus) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do + -- rec stmt1 + -- stmt2 + -- stmt3 + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts + ] + -- rec + -- stmt1 + -- stmt2 + -- stmt3 + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docLit (Text.pack "rec")) + (docLines $ layoutStmt <$> stmts) + BodyStmt _ expr _ _ -> do + expDoc <- docSharedWrapper layoutExpr expr + docAddBaseY BrIndentRegular $ expDoc + _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.Stmt where + +import GHC.Hs +import Language.Haskell.Brittany.Internal.Types + + + +layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -0,0 +1,643 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Layouters.Type where + +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Utils.Outputable (ftext, showSDocUnsafe) +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + (FirstLastView(..), splitFirstLast) + + + +layoutType :: ToBriDoc HsType +layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of + -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" + HsTyVar _ promoted name -> do + t <- lrdrNameToTextAnnTypeEqualityIsSpecial name + case promoted of + IsPromoted -> docSeq + [ docSeparator + , docTick + , docWrapNode name $ docLit t + ] + NotPromoted -> docWrapNode name $ docLit t + HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do + let bndrs = getBinders hsf + typeDoc <- docSharedWrapper layoutType typ2 + tyVarDocs <- layoutTyVarBndrs bndrs + cntxtDocs <- cntxts `forM` docSharedWrapper layoutType + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + let + tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs + forallDoc = docAlt + [ let + open = docLit $ Text.pack "forall" + in docSeq ([open]++tyVarDocLineList) + , docPar + (docLit (Text.pack "forall")) + (docLines + $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ]) + ] + contextDoc = case cntxtDocs of + [] -> docLit $ Text.pack "()" + [x] -> x + _ -> docAlt + [ let + open = docLit $ Text.pack "(" + close = docLit $ Text.pack ")" + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) + , let + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs + ] + close = docLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) cntxtDoc + ] + in docPar open $ docLines $ list ++ [close] + ] + docAlt + -- :: forall a b c . (Foo a b c) => a b -> c + [ docSeq + [ if null bndrs + then docEmpty + else let + open = docLit $ Text.pack "forall" + close = docLit $ Text.pack " . " + in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) + , docForceSingleline contextDoc + , docLit $ Text.pack " => " + , docForceSingleline typeDoc + ] + -- :: forall a b c + -- . (Foo a b c) + -- => a b + -- -> c + , docPar + forallDoc + ( docLines + [ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) + $ contextDoc + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] + ] + ) + ] + HsForAllTy _ hsf typ2 -> do + let bndrs = getBinders hsf + typeDoc <- layoutType typ2 + tyVarDocs <- layoutTyVarBndrs bndrs + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs + docAlt + -- forall x . x + [ docSeq + [ if null bndrs + then docEmpty + else let + open = docLit $ Text.pack "forall" + close = docLit $ Text.pack " . " + in docSeq ([open]++tyVarDocLineList++[close]) + , docForceSingleline $ return $ typeDoc + ] + -- :: forall x + -- . x + , docPar + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ) + -- :: forall + -- (x :: *) + -- . x + , docPar + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ] + ) + ++[ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ] + ) + ] + HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do + typeDoc <- docSharedWrapper layoutType typ1 + cntxtDocs <- cntxts `forM` docSharedWrapper layoutType + let + contextDoc = docWrapNode lcntxts $ case cntxtDocs of + [] -> docLit $ Text.pack "()" + [x] -> x + _ -> docAlt + [ let + open = docLit $ Text.pack "(" + close = docLit $ Text.pack ")" + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) + , let + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) + $ head cntxtDocs + ] + close = docLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) + $ cntxtDoc + ] + in docPar open $ docLines $ list ++ [close] + ] + let maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + docAlt + -- (Foo a b c) => a b -> c + [ docSeq + [ docForceSingleline contextDoc + , docLit $ Text.pack " => " + , docForceSingleline typeDoc + ] + -- (Foo a b c) + -- => a b + -- -> c + , docPar + (docForceSingleline contextDoc) + ( docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) + ] + HsFunTy _ _ typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + hasComments <- hasAnyCommentsBelow ltype + docAlt $ + [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 + ] + | not hasComments + ] ++ + [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) + $ maybeForceML typeDoc2 + ] + ) + ] + HsParTy _ typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack "(" + , docForceSingleline typeDoc1 + , docLit $ Text.pack ")" + ] + , docPar + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack ")") + ] + HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do + let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 + final -> (final, list) + let (typHead, typRest) = gather [typ2] typ1 + docHead <- docSharedWrapper layoutType typHead + docRest <- docSharedWrapper layoutType `mapM` typRest + docAlt + [ docSeq + $ docForceSingleline docHead : (docRest >>= \d -> + [ docSeparator, docForceSingleline d ]) + , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) + ] + HsAppTy _ typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + docAlt + [ docSeq + [ docForceSingleline typeDoc1 + , docSeparator + , docForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + (docEnsureIndent BrIndentRegular typeDoc2) + ] + HsListTy _ typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack "[" + , docForceSingleline typeDoc1 + , docLit $ Text.pack "]" + ] + , docPar + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack "]") + ] + HsTupleTy _ tupleSort typs -> case tupleSort of + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple + HsBoxedOrConstraintTuple -> simple + where + unboxed = if null typs then error "brittany internal error: unboxed unit" + else unboxedL + simple = if null typs then unitL else simpleL + unitL = docLit $ Text.pack "()" + simpleL = do + docs <- docSharedWrapper layoutType `mapM` typs + let end = docLit $ Text.pack ")" + lines = List.tail docs <&> \d -> + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) + docAlt + [ docSeq $ [docLit $ Text.pack "("] + ++ docWrapNodeRest ltype commaDocs + ++ [end] + , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] + in docPar + (docAddBaseY (BrIndentSpecial 2) $ line1) + (docLines $ docWrapNodeRest ltype lines ++ [end]) + ] + unboxedL = do + docs <- docSharedWrapper layoutType `mapM` typs + let start = docParenHashLSep + end = docParenHashRSep + docAlt + [ docSeq $ [start] + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) + ++ [end] + , let + line1 = docCols ColTyOpPrefix [start, head docs] + lines = List.tail docs <&> \d -> + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + in docPar + (docAddBaseY (BrIndentSpecial 2) line1) + (docLines $ lines ++ [end]) + ] + HsOpTy{} -> -- TODO + briDocByExactInlineOnly "HsOpTy{}" ltype + -- HsOpTy typ1 opName typ2 -> do + -- -- TODO: these need some proper fixing. precedences don't add up. + -- -- maybe the parser just returns some trivial right recursion + -- -- parse result for any type level operators. + -- -- need to check how things are handled on the expression level. + -- let opStr = lrdrNameToText opName + -- let opLen = Text.length opStr + -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 + -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 + -- let line = do -- Maybe + -- l1 <- _ldesc_line desc1 + -- l2 <- _ldesc_line desc2 + -- let len1 = _lColumns_min l1 + -- let len2 = _lColumns_min l2 + -- let len = 2 + opLen + len1 + len2 + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol1 <- descToBlockStart desc1 + -- (min2, max2) <- descToMinMax (1+opLen) desc2 + -- let (minR, maxR) = case descToBlockMinMax desc1 of + -- Nothing -> (min2, max2) + -- Just (min1, max1) -> (max min1 min2, max max1 max2) + -- return $ BlockDesc + -- { _bdesc_blockStart = rol1 + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Just (1+opLen) + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \params -> do + -- remaining <- getCurRemaining + -- let allowSameLine = _params_sepLines params /= SepLineTypeOp + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do + -- applyLayouterRestore layouter1 defaultParams + -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " + -- applyLayouterRestore layouter2 defaultParams + -- _ -> do + -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params + -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 + -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams + -- layoutWriteNewline + -- layoutWriteAppend $ opStr <> Text.pack " " + -- layoutWriteEnsureBlockPlusN downIndent + -- applyLayouterRestore layouter2 defaultParams + -- { _params_sepLines = SepLineTypeOp + -- , _params_opIndent = Just downIndent + -- } + -- , _layouter_ast = ltype + -- } + HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype + $ docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + , docForceSingleline typeDoc1 + ] + , docPar + ( docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) + ) + (docCols ColTyOpPrefix + [ docWrapNodeRest ltype + $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ]) + ] + -- TODO: test KindSig + HsKindSig _ typ1 kind1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + kindDoc1 <- docSharedWrapper layoutType kind1 + hasParens <- hasAnnKeyword ltype AnnOpenP + docAlt + [ if hasParens + then docSeq + [ docLit $ Text.pack "(" + , docForceSingleline typeDoc1 + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , docForceSingleline kindDoc1 + , docLit $ Text.pack ")" + ] + else docSeq + [ docForceSingleline typeDoc1 + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , docForceSingleline kindDoc1 + ] + , if hasParens + then docLines + [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 3) $ typeDoc1 + ] + , docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ] + , (docLit $ Text.pack ")") + ] + else docPar + typeDoc1 + ( docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ] + ) + ] + HsBangTy{} -> -- TODO + briDocByExactInlineOnly "HsBangTy{}" ltype + -- HsBangTy bang typ1 -> do + -- let bangStr = case bang of + -- HsSrcBang _ unpackness strictness -> + -- (++) + -- (case unpackness of + -- SrcUnpack -> "{-# UNPACK -#} " + -- SrcNoUnpack -> "{-# NOUNPACK -#} " + -- NoSrcUnpack -> "" + -- ) + -- (case strictness of + -- SrcLazy -> "~" + -- SrcStrict -> "!" + -- NoSrcStrict -> "" + -- ) + -- let bangLen = length bangStr + -- layouter@(Layouter desc _ _) <- layoutType typ1 + -- let line = do -- Maybe + -- l <- _ldesc_line desc + -- let len = bangLen + _lColumns_min l + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol <- descToBlockStart desc + -- (minR,maxR) <- descToBlockMinMax desc + -- return $ BlockDesc + -- { _bdesc_blockStart = rol + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Nothing + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \_params -> do + -- remaining <- getCurRemaining + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- applyLayouterRestore layouter defaultParams + -- _ -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- layoutWritePostCommentsRestore ltype + -- applyLayouterRestore layouter defaultParams + -- , _layouter_ast = ltype + -- } + HsSpliceTy{} -> -- TODO + briDocByExactInlineOnly "HsSpliceTy{}" ltype + HsDocTy{} -> -- TODO + briDocByExactInlineOnly "HsDocTy{}" ltype + HsRecTy{} -> -- TODO + briDocByExactInlineOnly "HsRecTy{}" ltype + HsExplicitListTy _ _ typs -> do + typDocs <- docSharedWrapper layoutType `mapM` typs + hasComments <- hasAnyCommentsBelow ltype + let specialCommaSep = appSep $ docLit $ Text.pack " ," + docAlt + [ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) + ++ [docLit $ Text.pack "]"] + , case splitFirstLast typDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "'[" + , docSeparator + , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e + ] + , docLit $ Text.pack " ]" + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) + ++ [docLit $ Text.pack " ]"] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> + docCols ColList [specialCommaSep, d] + lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ] + HsExplicitTupleTy{} -> -- TODO + briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype + HsTyLit _ lit -> case lit of + HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsNumTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsStrTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsWildCardTy _ -> + docLit $ Text.pack "_" + HsSumTy{} -> -- TODO + briDocByExactInlineOnly "HsSumTy{}" ltype + HsStarTy _ isUnicode -> do + if isUnicode + then docLit $ Text.pack "\x2605" -- Unicode star + else docLit $ Text.pack "*" + XHsType{} -> error "brittany internal error: XHsType" + HsAppKindTy _ ty kind -> do + t <- docSharedWrapper layoutType ty + k <- docSharedWrapper layoutType kind + docAlt + [ docSeq + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar + t + (docSeq [docLit $ Text.pack "@", k ]) + ] + +layoutTyVarBndrs + :: [LHsTyVarBndr () GhcPs] + -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] +layoutTyVarBndrs = mapM $ \case + (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ _ lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + +-- there is no specific reason this returns a list instead of a single +-- BriDoc node. +processTyVarBndrsSingleline + :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] +processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case + (tname, Nothing) -> [docSeparator, docLit tname] + (tname, Just doc) -> + [ docSeparator + , docLit $ Text.pack "(" <> tname <> Text.pack " :: " + , docForceSingleline $ doc + , docLit $ Text.pack ")" + ] + +getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] +getBinders x = case x of + HsForAllVis _ b -> b + HsForAllInvis _ b -> fmap withoutSpecificity b + XHsForAllTelescope _ -> [] + +withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass +withoutSpecificity = fmap $ \case + UserTyVar a _ c -> UserTyVar a () c + KindedTyVar a _ c d -> KindedTyVar a () c d + XTyVarBndr a -> XTyVarBndr a diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Obfuscation where + +import Data.Char +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import System.Random + + + +obfuscate :: Text -> IO Text +obfuscate input = do + let predi x = isAlphaNum x || x `elem` "_'" + let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) + let idents = Set.toList $ Set.fromList $ filter (all predi) groups + let exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x + let filtered = filter exceptionFilter idents + mappings <- fmap Map.fromList $ filtered `forM` \x -> do + r <- createAlias x + pure (x, r) + let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings) + pure $ Text.concat $ fmap Text.pack groups' + +keywords :: [String] +keywords = + [ "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "mdo" + , "else" + , "forall" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "qualified" + , "then" + , "type" + , "where" + , "_" + , "foreign" + , "ccall" + , "as" + , "safe" + , "unsafe" + , "hiding" + , "proc" + , "rec" + , "family" + ] + +extraKWs :: [String] +extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] + +createAlias :: String -> IO String +createAlias xs = go NoHint xs + where + go _hint "" = pure "" + go hint (c : cr) = do + c' <- case hint of + VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] + VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c + cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr + pure (c' : cr') + +data Hint = NoHint | VocalHint | NoVocalHint + +_randomRange :: Random a => a -> a -> IO a +_randomRange lo hi = do + gen <- getStdGen + let (x, gen') = randomR (lo, hi) gen + setStdGen gen' + pure x + +randomFrom :: [a] -> IO a +randomFrom l = do + let hi = length l - 1 + gen <- getStdGen + let (x, gen') = randomR (0, hi) gen + setStdGen gen' + pure $ l List.!! x diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs @@ -0,0 +1,500 @@ +{-# OPTIONS_GHC -Wno-implicit-prelude #-} + +module Language.Haskell.Brittany.Internal.ParseModule where + +import qualified Control.Monad as Monad +import qualified Control.Monad.IO.Class as IO +import qualified Control.Monad.Trans.Except as Except +import qualified Data.Set as Set +import qualified GHC +import qualified GHC.ByteOrder +import qualified GHC.Data.Bag +import qualified GHC.Data.EnumSet +import qualified GHC.Data.StringBuffer +import qualified GHC.Driver.Session +import qualified GHC.Parser.Header +import qualified GHC.Platform +import qualified GHC.Settings +import qualified GHC.Types.Basic +import qualified GHC.Types.SrcLoc +import qualified GHC.Unit.Module.Name +import qualified GHC.Unit.State +import qualified GHC.Unit.Types +import qualified GHC.Utils.Error +import qualified GHC.Utils.Fingerprint +import qualified GHC.Utils.Misc +import qualified GHC.Utils.Ppr.Colour +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint + +-- | Parses a Haskell module. Although this nominally requires IO, it is +-- morally pure. It should have no observable effects. +parseModule + :: IO.MonadIO io + => [String] + -> FilePath + -> (GHC.Driver.Session.DynFlags -> io (Either String a)) + -> String + -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do + let + dynFlags1 = GHC.Driver.Session.gopt_set + -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both + -- of those modes have trouble parsing safe imports (@import safe ...@). + -- Neither passing in @"-XUnsafe"@ as a command line argument nor having + -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. + initialDynFlags + { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe + } + GHC.Driver.Session.Opt_KeepRawTokenStream + (dynFlags2, leftovers1, _) <- + GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 + $ fmap GHC.Types.SrcLoc.noLoc arguments1 + handleLeftovers leftovers1 + let + stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string + arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath + (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma + dynFlags2 + arguments2 + handleLeftovers leftovers2 + dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 + let + parseResult = + ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string + case parseResult of + Left errorMessages -> handleErrorMessages errorMessages + Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) + +handleLeftovers + :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () +handleLeftovers leftovers = + Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show + (fmap GHC.Types.SrcLoc.unLoc leftovers) + +handleErrorMessages + :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a +handleErrorMessages = + Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList + +initialCfgWeights :: GHC.Driver.Session.CfgWeights +initialCfgWeights = GHC.Driver.Session.CFGWeights + { GHC.Driver.Session.backEdgeBonus = 0 + , GHC.Driver.Session.callWeight = 0 + , GHC.Driver.Session.condBranchWeight = 0 + , GHC.Driver.Session.infoTablePenalty = 0 + , GHC.Driver.Session.likelyCondWeight = 0 + , GHC.Driver.Session.switchWeight = 0 + , GHC.Driver.Session.uncondWeight = 0 + , GHC.Driver.Session.unlikelyCondWeight = 0 + } + +initialDynFlags :: GHC.Driver.Session.DynFlags +initialDynFlags = GHC.Driver.Session.DynFlags + { GHC.Driver.Session.avx = False + , GHC.Driver.Session.avx2 = False + , GHC.Driver.Session.avx512cd = False + , GHC.Driver.Session.avx512er = False + , GHC.Driver.Session.avx512f = False + , GHC.Driver.Session.avx512pf = False + , GHC.Driver.Session.binBlobThreshold = 0 + , GHC.Driver.Session.bmiVersion = Nothing + , GHC.Driver.Session.cachedPlugins = [] + , GHC.Driver.Session.canGenerateDynamicToo = error "canGenerateDynamicToo" + , GHC.Driver.Session.canUseColor = False + , GHC.Driver.Session.cfgWeightInfo = initialCfgWeights + , GHC.Driver.Session.cmdlineFrameworks = [] + , GHC.Driver.Session.cmmProcAlignment = Nothing + , GHC.Driver.Session.colScheme = GHC.Utils.Ppr.Colour.defaultScheme + , GHC.Driver.Session.debugLevel = 0 + , GHC.Driver.Session.depExcludeMods = [] + , GHC.Driver.Session.depIncludeCppDeps = False + , GHC.Driver.Session.depIncludePkgDeps = False + , GHC.Driver.Session.depMakefile = "" + , GHC.Driver.Session.depSuffixes = [] + , GHC.Driver.Session.dirsToClean = error "dirsToClean" + , GHC.Driver.Session.dump_action = \_ _ _ _ _ _ -> pure () + , GHC.Driver.Session.dumpDir = Nothing + , GHC.Driver.Session.dumpFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.dumpPrefix = Nothing + , GHC.Driver.Session.dumpPrefixForce = Nothing + , GHC.Driver.Session.dylibInstallName = Nothing + , GHC.Driver.Session.dynHiSuf = "" + , GHC.Driver.Session.dynLibLoader = GHC.Driver.Session.Deployable + , GHC.Driver.Session.dynObjectSuf = "" + , GHC.Driver.Session.dynOutputFile = Nothing + , GHC.Driver.Session.enableTimeStats = False + , GHC.Driver.Session.extensionFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.extensions = [] + , GHC.Driver.Session.fatalWarningFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.fileSettings = initialFileSettings + , GHC.Driver.Session.filesToClean = error "filesToClean" + , GHC.Driver.Session.floatLamArgs = Nothing + , GHC.Driver.Session.flushErr = GHC.Driver.Session.defaultFlushErr + , GHC.Driver.Session.flushOut = GHC.Driver.Session.defaultFlushOut + , GHC.Driver.Session.frameworkPaths = [] + , GHC.Driver.Session.frontendPluginOpts = [] + , GHC.Driver.Session.generalFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.generatedDumps = error "generatedDumps" + , GHC.Driver.Session.ghcHeapSize = Nothing + , GHC.Driver.Session.ghciHistSize = 0 + , GHC.Driver.Session.ghciScripts = [] + , GHC.Driver.Session.ghcLink = GHC.Driver.Session.NoLink + , GHC.Driver.Session.ghcMode = GHC.Driver.Session.OneShot + , GHC.Driver.Session.ghcNameVersion = initialGhcNameVersion + , GHC.Driver.Session.ghcVersionFile = Nothing + , GHC.Driver.Session.haddockOptions = Nothing + , GHC.Driver.Session.hcSuf = "" + , GHC.Driver.Session.hiDir = Nothing + , GHC.Driver.Session.hieDir = Nothing + , GHC.Driver.Session.hieSuf = "" + , GHC.Driver.Session.historySize = 0 + , GHC.Driver.Session.hiSuf = "" + , GHC.Driver.Session.homeUnitId = GHC.Unit.Types.stringToUnitId "" + , GHC.Driver.Session.homeUnitInstanceOfId = Nothing + , GHC.Driver.Session.homeUnitInstantiations = [] + , GHC.Driver.Session.hooks = error "hooks" + , GHC.Driver.Session.hpcDir = "" + , GHC.Driver.Session.hscTarget = GHC.Driver.Session.HscNothing + , GHC.Driver.Session.ignorePackageFlags = [] + , GHC.Driver.Session.importPaths = [] + , GHC.Driver.Session.includePaths = initialIncludeSpecs + , GHC.Driver.Session.incoherentOnLoc = initialSrcSpan + , GHC.Driver.Session.initialUnique = 0 + , GHC.Driver.Session.inlineCheck = Nothing + , GHC.Driver.Session.interactivePrint = Nothing + , GHC.Driver.Session.language = Nothing + , GHC.Driver.Session.ldInputs = [] + , GHC.Driver.Session.liberateCaseThreshold = Nothing + , GHC.Driver.Session.libraryPaths = [] + , GHC.Driver.Session.liftLamsKnown = False + , GHC.Driver.Session.liftLamsNonRecArgs = Nothing + , GHC.Driver.Session.liftLamsRecArgs = Nothing + , GHC.Driver.Session.llvmConfig = initialLlvmConfig + , GHC.Driver.Session.log_action = \_ _ _ _ _ -> pure () + , GHC.Driver.Session.mainFunIs = Nothing + , GHC.Driver.Session.mainModIs = GHC.Unit.Types.mkModule + (GHC.Unit.Types.stringToUnit "") + (GHC.Unit.Module.Name.mkModuleName "") + , GHC.Driver.Session.maxErrors = Nothing + , GHC.Driver.Session.maxInlineAllocSize = 0 + , GHC.Driver.Session.maxInlineMemcpyInsns = 0 + , GHC.Driver.Session.maxInlineMemsetInsns = 0 + , GHC.Driver.Session.maxPmCheckModels = 0 + , GHC.Driver.Session.maxRefHoleFits = Nothing + , GHC.Driver.Session.maxRelevantBinds = Nothing + , GHC.Driver.Session.maxSimplIterations = 0 + , GHC.Driver.Session.maxUncoveredPatterns = 0 + , GHC.Driver.Session.maxValidHoleFits = Nothing + , GHC.Driver.Session.maxWorkerArgs = 0 + , GHC.Driver.Session.newDerivOnLoc = initialSrcSpan + , GHC.Driver.Session.nextTempSuffix = error "nextTempSuffix" + , GHC.Driver.Session.nextWrapperNum = error "nextWrapperNum" + , GHC.Driver.Session.objectDir = Nothing + , GHC.Driver.Session.objectSuf = "" + , GHC.Driver.Session.optLevel = 0 + , GHC.Driver.Session.outputFile = Nothing + , GHC.Driver.Session.outputHi = Nothing + , GHC.Driver.Session.overlapInstLoc = initialSrcSpan + , GHC.Driver.Session.packageDBFlags = [] + , GHC.Driver.Session.packageEnv = Nothing + , GHC.Driver.Session.packageFlags = [] + , GHC.Driver.Session.parMakeCount = Nothing + , GHC.Driver.Session.pkgTrustOnLoc = initialSrcSpan + , GHC.Driver.Session.platformConstants = initialPlatformConstants + , GHC.Driver.Session.platformMisc = initialPlatformMisc + , GHC.Driver.Session.pluginModNameOpts = [] + , GHC.Driver.Session.pluginModNames = [] + , GHC.Driver.Session.pluginPackageFlags = [] + , GHC.Driver.Session.pprCols = 80 + , GHC.Driver.Session.pprUserLength = 0 + , GHC.Driver.Session.profAuto = GHC.Driver.Session.NoProfAuto + , GHC.Driver.Session.rawSettings = [] + , GHC.Driver.Session.reductionDepth = GHC.Types.Basic.mkIntWithInf 0 + , GHC.Driver.Session.refLevelHoleFits = Nothing + , GHC.Driver.Session.reverseErrors = False + , GHC.Driver.Session.rtccInfo = error "rtccInfo" + , GHC.Driver.Session.rtldInfo = error "rtldInfo" + , GHC.Driver.Session.rtsOpts = Nothing + , GHC.Driver.Session.rtsOptsEnabled = GHC.Driver.Session.RtsOptsNone + , GHC.Driver.Session.rtsOptsSuggestions = False + , GHC.Driver.Session.ruleCheck = Nothing + , GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Ignore + , GHC.Driver.Session.safeInfer = False + , GHC.Driver.Session.safeInferred = False + , GHC.Driver.Session.simplPhases = 0 + , GHC.Driver.Session.simplTickFactor = 0 + , GHC.Driver.Session.solverIterations = GHC.Types.Basic.mkIntWithInf 0 + , GHC.Driver.Session.specConstrCount = Nothing + , GHC.Driver.Session.specConstrRecursive = 0 + , GHC.Driver.Session.specConstrThreshold = Nothing + , GHC.Driver.Session.splitInfo = Nothing + , GHC.Driver.Session.sseVersion = Nothing + , GHC.Driver.Session.staticPlugins = [] + , GHC.Driver.Session.strictnessBefore = [] + , GHC.Driver.Session.stubDir = Nothing + , GHC.Driver.Session.targetPlatform = initialTargetPlatform + , GHC.Driver.Session.thOnLoc = initialSrcSpan + , GHC.Driver.Session.toolSettings = initialToolSettings + , GHC.Driver.Session.trace_action = \_ _ _ a -> a + , GHC.Driver.Session.trustFlags = [] + , GHC.Driver.Session.trustworthyOnLoc = initialSrcSpan + , GHC.Driver.Session.ufCreationThreshold = 0 + , GHC.Driver.Session.ufDearOp = 0 + , GHC.Driver.Session.ufDictDiscount = 0 + , GHC.Driver.Session.ufFunAppDiscount = 0 + , GHC.Driver.Session.ufUseThreshold = 0 + , GHC.Driver.Session.ufVeryAggressive = False + , GHC.Driver.Session.uniqueIncrement = 0 + , GHC.Driver.Session.unitDatabases = Nothing + , GHC.Driver.Session.unitState = GHC.Unit.State.emptyUnitState + , GHC.Driver.Session.useColor = GHC.Utils.Misc.Never + , GHC.Driver.Session.useUnicode = False + , GHC.Driver.Session.verbosity = 0 + , GHC.Driver.Session.warningFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.warnSafeOnLoc = initialSrcSpan + , GHC.Driver.Session.warnUnsafeOnLoc = initialSrcSpan + , GHC.Driver.Session.ways = Set.empty + } + +initialFileSettings :: GHC.Driver.Session.FileSettings +initialFileSettings = GHC.Driver.Session.FileSettings + { GHC.Driver.Session.fileSettings_ghciUsagePath = "" + , GHC.Driver.Session.fileSettings_ghcUsagePath = "" + , GHC.Driver.Session.fileSettings_globalPackageDatabase = "" + , GHC.Driver.Session.fileSettings_tmpDir = "" + , GHC.Driver.Session.fileSettings_toolDir = Nothing + , GHC.Driver.Session.fileSettings_topDir = "" + } + +initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion +initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion + { GHC.Driver.Session.ghcNameVersion_programName = "" + , GHC.Driver.Session.ghcNameVersion_projectVersion = "" + } + +initialIncludeSpecs :: GHC.Driver.Session.IncludeSpecs +initialIncludeSpecs = GHC.Driver.Session.IncludeSpecs + { GHC.Driver.Session.includePathsGlobal = [] + , GHC.Driver.Session.includePathsQuote = [] + } + +initialLlvmConfig :: GHC.Driver.Session.LlvmConfig +initialLlvmConfig = GHC.Driver.Session.LlvmConfig + { GHC.Driver.Session.llvmPasses = [] + , GHC.Driver.Session.llvmTargets = [] + } + +initialPlatformConstants :: GHC.Settings.PlatformConstants +initialPlatformConstants = GHC.Settings.PlatformConstants + { GHC.Settings.pc_AP_STACK_SPLIM = 0 + , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0 + , GHC.Settings.pc_BLOCK_SIZE = 0 + , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0 + , GHC.Settings.pc_CINT_SIZE = 0 + , GHC.Settings.pc_CLONG_LONG_SIZE = 0 + , GHC.Settings.pc_CLONG_SIZE = 0 + , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0 + , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False + , GHC.Settings.pc_ILDV_CREATE_MASK = 0 + , GHC.Settings.pc_ILDV_STATE_CREATE = 0 + , GHC.Settings.pc_ILDV_STATE_USE = 0 + , GHC.Settings.pc_LDV_SHIFT = 0 + , GHC.Settings.pc_MAX_CHARLIKE = 0 + , GHC.Settings.pc_MAX_Double_REG = 0 + , GHC.Settings.pc_MAX_Float_REG = 0 + , GHC.Settings.pc_MAX_INTLIKE = 0 + , GHC.Settings.pc_MAX_Long_REG = 0 + , GHC.Settings.pc_MAX_Real_Double_REG = 0 + , GHC.Settings.pc_MAX_Real_Float_REG = 0 + , GHC.Settings.pc_MAX_Real_Long_REG = 0 + , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0 + , GHC.Settings.pc_MAX_Real_XMM_REG = 0 + , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0 + , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0 + , GHC.Settings.pc_MAX_Vanilla_REG = 0 + , GHC.Settings.pc_MAX_XMM_REG = 0 + , GHC.Settings.pc_MIN_CHARLIKE = 0 + , GHC.Settings.pc_MIN_INTLIKE = 0 + , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0 + , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0 + , GHC.Settings.pc_OFFSET_bdescr_blocks = 0 + , GHC.Settings.pc_OFFSET_bdescr_flags = 0 + , GHC.Settings.pc_OFFSET_bdescr_free = 0 + , GHC.Settings.pc_OFFSET_bdescr_start = 0 + , GHC.Settings.pc_OFFSET_Capability_r = 0 + , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0 + , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0 + , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0 + , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0 + , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 + , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0 + , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0 + , GHC.Settings.pc_OFFSET_stgGCFun = 0 + , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0 + , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0 + , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0 + , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0 + , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 + , GHC.Settings.pc_OFFSET_StgStack_sp = 0 + , GHC.Settings.pc_OFFSET_StgStack_stack = 0 + , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0 + , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0 + , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0 + , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0 + , GHC.Settings.pc_PROF_HDR_SIZE = 0 + , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0 + , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0 + , GHC.Settings.pc_REP_StgEntCounter_allocd = 0 + , GHC.Settings.pc_REP_StgEntCounter_allocs = 0 + , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0 + , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0 + , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0 + , GHC.Settings.pc_RESERVED_STACK_WORDS = 0 + , GHC.Settings.pc_SIZEOF_CostCentreStack = 0 + , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0 + , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0 + , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 + , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 + , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0 + , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 + , GHC.Settings.pc_STD_HDR_SIZE = 0 + , GHC.Settings.pc_TAG_BITS = 0 + , GHC.Settings.pc_TICKY_BIN_COUNT = 0 + , GHC.Settings.pc_WORD_SIZE = 0 + } + +initialPlatformMini :: GHC.Settings.PlatformMini +initialPlatformMini = GHC.Settings.PlatformMini + { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 + , GHC.Settings.platformMini_os = GHC.Platform.OSLinux + } + +initialPlatformMisc :: GHC.Driver.Session.PlatformMisc +initialPlatformMisc = GHC.Driver.Session.PlatformMisc + { GHC.Driver.Session.platformMisc_ghcDebugged = False + , GHC.Driver.Session.platformMisc_ghcRTSWays = "" + , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False + , GHC.Driver.Session.platformMisc_ghcThreaded = False + , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False + , GHC.Driver.Session.platformMisc_ghcWithSMP = False + , GHC.Driver.Session.platformMisc_libFFI = False + , GHC.Driver.Session.platformMisc_llvmTarget = "" + , GHC.Driver.Session.platformMisc_targetPlatformString = "" + } + +initialSrcSpan :: GHC.Types.SrcLoc.SrcSpan +initialSrcSpan = + GHC.Types.SrcLoc.UnhelpfulSpan GHC.Types.SrcLoc.UnhelpfulNoLocationInfo + +initialTargetPlatform :: GHC.Settings.Platform +initialTargetPlatform = GHC.Settings.Platform + { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian + , GHC.Settings.platformHasGnuNonexecStack = False + , GHC.Settings.platformHasIdentDirective = False + , GHC.Settings.platformHasSubsectionsViaSymbols = False + , GHC.Settings.platformIsCrossCompiling = False + , GHC.Settings.platformLeadingUnderscore = False + , GHC.Settings.platformMini = initialPlatformMini + , GHC.Settings.platformTablesNextToCode = False + , GHC.Settings.platformUnregisterised = False + , GHC.Settings.platformWordSize = GHC.Platform.PW8 + } + +initialToolSettings :: GHC.Settings.ToolSettings +initialToolSettings = GHC.Settings.ToolSettings + { GHC.Settings.toolSettings_ccSupportsNoPie = False + , GHC.Settings.toolSettings_extraGccViaCFlags = [] + , GHC.Settings.toolSettings_ldIsGnuLd = False + , GHC.Settings.toolSettings_ldSupportsBuildId = False + , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False + , GHC.Settings.toolSettings_ldSupportsFilelist = False + , GHC.Settings.toolSettings_opt_a = [] + , GHC.Settings.toolSettings_opt_c = [] + , GHC.Settings.toolSettings_opt_cxx = [] + , GHC.Settings.toolSettings_opt_F = [] + , GHC.Settings.toolSettings_opt_i = [] + , GHC.Settings.toolSettings_opt_l = [] + , GHC.Settings.toolSettings_opt_L = [] + , GHC.Settings.toolSettings_opt_lc = [] + , GHC.Settings.toolSettings_opt_lcc = [] + , GHC.Settings.toolSettings_opt_lm = [] + , GHC.Settings.toolSettings_opt_lo = [] + , GHC.Settings.toolSettings_opt_P = [] + , GHC.Settings.toolSettings_opt_P_fingerprint = + GHC.Utils.Fingerprint.fingerprint0 + , GHC.Settings.toolSettings_opt_windres = [] + , GHC.Settings.toolSettings_pgm_a = ("", []) + , GHC.Settings.toolSettings_pgm_ar = "" + , GHC.Settings.toolSettings_pgm_c = "" + , GHC.Settings.toolSettings_pgm_dll = ("", []) + , GHC.Settings.toolSettings_pgm_F = "" + , GHC.Settings.toolSettings_pgm_i = "" + , GHC.Settings.toolSettings_pgm_install_name_tool = "" + , GHC.Settings.toolSettings_pgm_l = ("", []) + , GHC.Settings.toolSettings_pgm_L = "" + , GHC.Settings.toolSettings_pgm_lc = ("", []) + , GHC.Settings.toolSettings_pgm_lcc = ("", []) + , GHC.Settings.toolSettings_pgm_libtool = "" + , GHC.Settings.toolSettings_pgm_lm = ("", []) + , GHC.Settings.toolSettings_pgm_lo = ("", []) + , GHC.Settings.toolSettings_pgm_otool = "" + , GHC.Settings.toolSettings_pgm_P = ("", []) + , GHC.Settings.toolSettings_pgm_ranlib = "" + , GHC.Settings.toolSettings_pgm_T = "" + , GHC.Settings.toolSettings_pgm_windres = "" + } diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs @@ -0,0 +1,194 @@ +module Language.Haskell.Brittany.Internal.Prelude + ( module E + ) where + +import Control.Applicative as E (Alternative(..), Applicative(..)) +import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) +import Control.Concurrent as E (forkIO, forkOS, threadDelay) +import Control.Concurrent.Chan as E (Chan) +import Control.Concurrent.MVar as E + (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) +import Control.Exception as E (assert, bracket, evaluate) +import Control.Monad as E + ( (<$!>) + , (<=<) + , (=<<) + , (>=>) + , Functor(..) + , Monad(..) + , MonadPlus(..) + , filterM + , forM + , forM_ + , forever + , guard + , join + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , mapM + , mapM_ + , replicateM + , replicateM_ + , sequence + , sequence_ + , unless + , void + , when + ) +import Control.Monad.Extra as E + (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) +import Control.Monad.IO.Class as E (MonadIO(..)) +import Control.Monad.ST as E (ST) +import Control.Monad.Trans.Class as E (lift) +import Control.Monad.Trans.Maybe as E (MaybeT(..)) +import Control.Monad.Trans.MultiRWS as E + (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) +import Data.Bifunctor as E (bimap) +import Data.Bool as E (Bool(..)) +import Data.Char as E (Char, chr, ord) +import Data.Data as E (toConstr) +import Data.Either as E (Either(..), either) +import Data.Foldable as E (asum, fold, foldl', foldr') +import Data.Function as E ((&), fix) +import Data.Functor as E (($>)) +import Data.Functor.Identity as E (Identity(..)) +import Data.IORef as E (IORef) +import Data.Int as E (Int) +import Data.List as E + ( all + , break + , drop + , dropWhile + , elem + , filter + , find + , intercalate + , intersperse + , isPrefixOf + , isSuffixOf + , iterate + , length + , mapAccumL + , mapAccumR + , maximum + , minimum + , notElem + , nub + , null + , partition + , repeat + , replicate + , sortBy + , sum + , take + , takeWhile + , transpose + , uncons + , unzip + , zip + , zip3 + , zipWith + ) +import Data.List.Extra as E (nubOrd, stripSuffix) +import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) +import Data.Map as E (Map) +import Data.Maybe as E + (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) +import Data.Monoid as E + ( All(..) + , Alt(..) + , Any(..) + , Endo(..) + , Monoid(..) + , Product(..) + , Sum(..) + , mconcat + ) +import Data.Ord as E (Down(..), Ordering(..), comparing) +import Data.Proxy as E (Proxy(..)) +import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) +import Data.Semigroup as E ((<>), Semigroup(..)) +import Data.Sequence as E (Seq) +import Data.Set as E (Set) +import Data.String as E (String) +import Data.Text as E (Text) +import Data.Tree as E (Tree(..)) +import Data.Tuple as E (swap) +import Data.Typeable as E (Typeable) +import Data.Version as E (showVersion) +import Data.Void as E (Void) +import Data.Word as E (Word, Word32) +import Debug.Trace as E + ( trace + , traceIO + , traceId + , traceM + , traceShow + , traceShowId + , traceShowM + , traceStack + ) +import Foreign.ForeignPtr as E (ForeignPtr) +import Foreign.Storable as E (Storable) +import GHC.Exts as E (Constraint) +import GHC.Hs.Extension as E (GhcPs) +import GHC.Types.Name.Reader as E (RdrName) +import Prelude as E + ( ($) + , ($!) + , (&&) + , (++) + , (.) + , (<$>) + , Bounded(..) + , Double + , Enum(..) + , Eq(..) + , Float + , Floating(..) + , Foldable + , Fractional(..) + , Integer + , Integral(..) + , Num(..) + , Ord(..) + , RealFloat(..) + , RealFrac(..) + , Show(..) + , Traversable + , (^) + , and + , any + , const + , curry + , error + , flip + , foldl + , foldr + , foldr1 + , fromIntegral + , fst + , head + , id + , map + , not + , or + , otherwise + , print + , putStr + , putStrLn + , realToFrac + , reverse + , seq + , snd + , subtract + , traverse + , uncurry + , undefined + , (||) + ) +import System.IO as E (IO, hFlush, stdout) +import Text.Read as E (readMaybe) diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Haskell.Brittany.Internal.PreludeUtils where + +import Control.Applicative +import Control.DeepSeq (NFData, force) +import Control.Exception.Base (evaluate) +import Control.Monad +import qualified Data.Strict.Maybe as Strict +import Debug.Trace +import Prelude +import System.IO + + + +instance Applicative Strict.Maybe where + pure = Strict.Just + Strict.Just f <*> Strict.Just x = Strict.Just (f x) + _ <*> _ = Strict.Nothing + +instance Monad Strict.Maybe where + Strict.Nothing >>= _ = Strict.Nothing + Strict.Just x >>= f = f x + +instance Alternative Strict.Maybe where + empty = Strict.Nothing + x <|> Strict.Nothing = x + _ <|> x = x + +traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +traceFunctionWith name s1 s2 f x = trace traceStr y + where + y = f x + traceStr = + name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y + +(<&!>) :: Monad m => m a -> (a -> b) -> m b +(<&!>) = flip (<$!>) + +putStrErrLn :: String -> IO () +putStrErrLn s = hPutStrLn stderr s + +putStrErr :: String -> IO () +putStrErr s = hPutStr stderr s + +printErr :: Show a => a -> IO () +printErr = putStrErrLn . show + +errorIf :: Bool -> a -> a +errorIf False = id +errorIf True = error "errorIf" + +errorIfNote :: Maybe String -> a -> a +errorIfNote Nothing = id +errorIfNote (Just x) = error x + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap +infixl 4 <&> + +(.>) :: (a -> b) -> (b -> c) -> (a -> c) +f .> g = g . f +infixl 9 .> + +evaluateDeep :: NFData a => a -> IO a +evaluateDeep = evaluate . force diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -0,0 +1,907 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Language.Haskell.Brittany.Internal.Transformations.Alt where + +import qualified Control.Monad.Memo as Memo +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.HList.ContainsType +import qualified Data.List.Extra +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + + + +data AltCurPos = AltCurPos + { _acp_line :: Int -- chars in the current line + , _acp_indent :: Int -- current indentation level + , _acp_indentPrep :: Int -- indentChange affecting the next Par + , _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) + +altLineModeRefresh :: AltLineModeState -> AltLineModeState +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction + +altLineModeDecay :: AltLineModeState -> AltLineModeState +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay 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 + ) + => BriDocNumbered + -> MultiRWSS.MultiRWS r w s BriDoc +transformAlts = + MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) + . Memo.startEvalMemoT + . fmap unwrapBriDocNumbered + . rec + where + -- this function is exponential by nature and cannot be improved in any + -- way i can think of, and i've tried. (stupid StableNames.) + -- transWrap :: BriDoc -> BriDocNumbered + -- transWrap brDc = flip StateS.evalState (1::Int) + -- $ Memo.startEvalMemoT + -- $ go brDc + -- where + -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i + -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered + -- go = Memo.memo $ \bdX -> do + -- i <- lift $ incGet + -- fmap (\bd' -> (i,bd')) $ case bdX of + -- BDEmpty -> return $ BDFEmpty + -- BDLit t -> return $ BDFLit t + -- BDSeq list -> BDFSeq <$> go `mapM` list + -- BDCols sig list -> BDFCols sig <$> go `mapM` list + -- BDSeparator -> return $ BDFSeparator + -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd + -- BDSetBaseY bd -> BDFSetBaseY <$> go bd + -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd + -- BDPar ind line indented -> [ BDFPar ind line' indented' + -- | line' <- go line + -- , indented' <- go indented + -- ] + -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen + -- BDForceMultiline bd -> BDFForceMultiline <$> go bd + -- BDForceSingleline bd -> BDFForceSingleline <$> go bd + -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd + -- BDExternal k ks c t -> return $ BDFExternal k ks c t + -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd + -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd + -- BDLines lines -> BDFLines <$> go `mapM` lines + -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd + -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd + + + + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered + rec bdX@(brDcId, brDc) = do + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> + reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> + reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd + mSet $ acp + { _acp_indent = ind + , _acp_indentPrep = 0 + } + sameLine' <- rec sameLine + mModify $ \acp' -> acp' + { _acp_line = ind + , _acp_indent = ind + } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> 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[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + 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{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk + 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)) + 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{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk + 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)) + let checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode 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 + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l:lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp + { _acp_line = ind + , _acp_indent = ind + } + rec x + return $ reWrap $ BDFLines (l':lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing _ bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + +getSpacing + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => BriDocNumbered + -> m (LineModeValidity VerticalSpacing) +getSpacing !bridoc = rec bridoc + where + rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) + rec (brDcId, brDc) = do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + result <- case brDc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLit t -> + return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False + BDFSeq list -> + sumVs <$> rec `mapM` list + BDFCols _sig list -> sumVs <$> rec `mapM` list + BDFSeparator -> + return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur 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) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = VerticalSpacingParSome 0 + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVs <- rec sameLine + mIndSp <- rec indented + return + $ [ VerticalSpacing lsp pspResult parFlagResult + | VerticalSpacing lsp mPsp _ <- mVs + , indSp <- mIndSp + , lineMax <- getMaxVS $ mIndSp + , let pspResult = case mPsp of + VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax + , let parFlagResult = mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ] + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + BDFAlt (alt:_) -> rec alt + BDFForceMultiline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> LineModeInvalid + _ -> mVs + BDFForceSingleline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> mVs + _ -> LineModeInvalid + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of + [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False + BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of + [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> return + $ LineModeValid + $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_:_) -> do + lSps <- rec `mapM` ls + let (mVs:_) = lSps -- separated into let to avoid MonadFail + return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp pf) -> + VerticalSpacing (lsp + addInd) psp pf + BDFNonBottomSpacing b bd -> do + mVs <- rec bd + return + $ mVs + <|> LineModeValid + (VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r + return r + return result + maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs = foldl' + (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing (max x1 y1) (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) False)) + (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs sps = foldl' (liftM2 go) initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y) + x3 + singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone + singleline _ = False + isPar (LineModeValid x) = _vs_parFlag x + isPar _ = False + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int + getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + +data SpecialCompare = Unequal | Smaller | Bigger + +getSpacings + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => Int + -> BriDocNumbered + -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] +getSpacings limit bridoc = preFilterLimit <$> rec bridoc + where + -- when we do `take K . filter someCondition` on a list of spacings, we + -- need to first (also) limit the size of the input list, otherwise a + -- _large_ input with a similarly _large_ prefix not passing our filtering + -- process could lead to exponential runtime behaviour. + -- TODO: 3 is arbitrary. + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3*limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let hasOkColCount (VerticalSpacing lsp psp _) = + lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let specialCompare vs1 vs2 = + if ( (_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let allowHangingQuasiQuotes = + config + & _conf_layout + & _lconfig_allowHangingQuasiQuotes + & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . specialNub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFSeparator -> + return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur 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) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit + $ [ (x,y) + | x<-mVss + , y<-indSps + ] + return $ mVsIndSp <&> + \(VerticalSpacing lsp mPsp _, indSp) -> + VerticalSpacing + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp) + ( mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> + return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1 ] -> VerticalSpacing + (Text.length t1) + VerticalSpacingParNone + False + (t1 : _) -> VerticalSpacing + (Text.length t1) + (VerticalSpacingParAlways 0) + True + | allowHangingQuasiQuotes + ] + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_:_) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- map filterAndLimit <$> rec `mapM` ls + let worbled = fmap reverse + $ sequence + $ reverse + $ lSpss + sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + sumF [] = error $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse 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 $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. + mVs <- rec bd + return $ if null mVs + then [VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] + else mVs <&> \vs -> vs + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) + return r + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) + False) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + +fixIndentationForMultiple + :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int +fixIndentationForMultiple acp indent = do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + -- for IndentPolicyMultiple, we restrict the amount of added + -- indentation in such a manner that we end up on a multiple of the + -- base indentation. + indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + pure $ if indPolicy == IndentPolicyMultiple + then + let indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 + else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Transformations.Columns where + +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types + + + +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 $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) + | all (\case BDSeparator -> True; _ -> False) rest -> + Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) + 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 + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + -- 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 + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing + BDIndentLevelPushCur{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing + BDForceSingleline{} -> Nothing + BDForwardLineMode{} -> Nothing + BDExternal{} -> Nothing + BDPlain{} -> Nothing + BDLines{} -> Nothing + BDAnnotationPrior{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing + BDForceParSpacing{} -> Nothing + BDDebug{} -> Nothing + BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Transformations.Floating where + +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + + + +-- 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. + -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence + -- the push/pop cases would need to be copied over + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + BDAddBaseY BrIndentNone x -> + Just x + -- AddIndent floats into Lines. + 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] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> + Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + BDAddBaseY BrIndentNone x -> + Just $ x + -- AddIndent floats into Lines. + 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 + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Transformations.Indent where + +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types + + + +-- 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 BrIndentNone _ _ -> Nothing + BDPar ind x indented -> + Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind 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] + BDLines [l] -> Just l + BDAddBaseY i (BDAnnotationPrior k x) -> + Just $ BDAnnotationPrior k (BDAddBaseY i x) + BDAddBaseY i (BDAnnotationKW k kw x) -> + Just $ BDAnnotationKW k kw (BDAddBaseY i x) + BDAddBaseY i (BDAnnotationRest k x) -> + Just $ BDAnnotationRest k (BDAddBaseY i x) + BDAddBaseY i (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 diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Transformations.Par where + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + + + +transformSimplifyPar :: BriDoc -> BriDoc +transformSimplifyPar = transformUp $ \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]) + x@(BDPar _ (BDPar _ BDPar{} _) _) -> x + BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> + BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) + BDPar ind1 (BDPar ind2 line p1) p2 -> + BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs + where + go = (=<<) $ \case + BDLines l -> go l + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> 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 -> x + x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Haskell.Brittany.Internal.Types where + +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Data.Data +import Data.Generics.Uniplate.Direct as Uniplate +import qualified Data.Kind as Kind +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint (AnnKey) +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Types (Anns) +import qualified Safe + + +data PerItemConfig = PerItemConfig + { _icd_perBinding :: Map String (CConfig Maybe) + , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) + } + deriving Data.Data.Data + +type PPM = MultiRWSS.MultiRWS + '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] + +type PPMLocal = MultiRWSS.MultiRWS + '[Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] + +newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) + +data LayoutState = LayoutState + { _lstate_baseYs :: [Int] + -- ^ stack of number of current indentation columns + -- (not number of indentations). + , _lstate_curYOrAddNewline :: Either Int Int + -- ^ Either: + -- 1) number of chars in the current line. + -- 2) number of newlines to be inserted before inserting any + -- non-space elements. + , _lstate_indLevels :: [Int] + -- ^ stack of current indentation levels. set for + -- any layout-affected elements such as + -- let/do/case/where elements. + -- The main purpose of this member is to + -- properly align comments, as their + -- annotation positions are relative to the + -- current layout indentation level. + , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for + -- properly treating cases where comments + -- on the first indented element have an + -- annotation offset relative to the last + -- non-indented element, which is confusing. + , _lstate_comments :: Anns + , _lstate_commentCol :: Maybe Int -- this communicates two things: + -- firstly, that cursor is currently + -- at the end of a comment (so needs + -- newline before any actual content). + -- secondly, the column at which + -- insertion of comments started. + , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone + -- writes (any non-spaces) in the + -- current line. + -- , _lstate_isNewline :: NewLineState + -- -- captures if the layouter currently is in a new line, i.e. if the + -- -- current line only contains (indentation) spaces. + -- this is mostly superseeded by curYOrAddNewline, iirc. + , _lstate_commentNewlines :: Int -- number of newlines inserted due to + -- move-to-DP at a start of a comment. + -- Necessary because some keyword DPs + -- are relative to the last non-comment + -- entity (for some reason). + -- This is not very strictly reset to 0, + -- so we might in some cases get "artifacts" + -- from previous document elements. + -- But the worst effect at the moment would + -- be that we introduce less newlines on + -- moveToKWDP, which seems harmless enough. + } + +lstate_baseY :: LayoutState -> Int +lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs + +lstate_indLevel :: LayoutState -> Int +lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels + +-- evil, incomplete Show instance; only for debugging. +instance Show LayoutState where + show state = + "LayoutState" + ++ "{baseYs=" ++ show (_lstate_baseYs state) + ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) + ++ ",indLevels=" ++ show (_lstate_indLevels state) + ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) + ++ ",commentCol=" ++ show (_lstate_commentCol state) + ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) + ++ "}" + +-- 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 BrittanyError + = ErrorInput String + -- ^ parsing failed + | ErrorUnusedComment String + -- ^ internal error: some comment went missing + | ErrorMacroConfig String String + -- ^ in-source config string parsing error; first argument is the parser + -- output and second the corresponding, ill-formed input. + | LayoutWarning String + -- ^ some warning + | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) + -- ^ internal error: pretty-printing is not implemented for type of node + -- in the syntax-tree + | ErrorOutputCheck + -- ^ checking the output for syntactic validity failed + +data BriSpacing = BriSpacing + { _bs_spacePastLineIndent :: Int -- space in the current, + -- potentially somewhat filled + -- line. + , _bs_spacePastIndent :: Int -- space required in properly + -- indented blocks below the + -- current line. + } + +data ColSig + = ColTyOpPrefix + -- any prefixed operator/paren/"::"/.. + -- expected to have exactly two colums. + -- e.g. ":: foo" + -- 111222 + -- "-> bar asd asd" + -- 11122222222222 + | ColPatternsFuncPrefix + -- pattern-part of the lhs, e.g. "func (foo a b) c _". + -- Has variable number of columns depending on the number of patterns. + | ColPatternsFuncInfix + -- pattern-part of the lhs, e.g. "Foo a <> Foo b". + -- Has variable number of columns depending on the number of patterns. + | ColPatterns + | ColCasePattern + | ColBindingLine (Maybe Text) + -- e.g. "func pat pat = expr" + -- 1111111111111222222 + -- or "pat | stmt -> expr" + -- 111111111112222222 + -- expected to have exactly two columns. + | ColGuard + -- e.g. "func pat pat | cond = ..." + -- 11111111111112222222 + -- or "pat | cond1, cond2 -> ..." + -- 1111222222222222222 + -- expected to have exactly two columns + | ColGuardedBody + -- e.g. | foofoo = 1 + -- | bar = 2 + -- 111111111222 + -- expected to have exactly two columns + | ColBindStmt + | ColDoLet -- the non-indented variant + | ColRec + | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRecDecl + | ColListComp + | ColList + | ColApp Text + | ColTuple + | ColTuples + | ColOpPrefix -- merge with ColList ? other stuff? + | ColImport + + -- TODO + deriving (Eq, Ord, Data.Data.Data, Show) + +data BrIndent = BrIndentNone + | BrIndentRegular + | BrIndentSpecial Int + deriving (Eq, Ord, Data.Data.Data, Show) + +type ToBriDocM = MultiRWSS.MultiRWS + '[Config, Anns] -- reader + '[[BrittanyError], Seq String] -- writer + '[NodeAllocIndex] -- state + +type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = Located sym -> ToBriDocM c + +data DocMultiLine + = MultiLineNo + | MultiLinePossible + deriving (Eq) + +-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot +-- of transformations on `BriDocF Identity`s and it is really annoying to +-- `Identity`/`runIdentity` everywhere. +data BriDoc + = -- BDWrapAnnKey AnnKey BriDoc + BDEmpty + | BDLit !Text + | BDSeq [BriDoc] -- elements other than the last should + -- not contains BDPars. + | BDCols ColSig [BriDoc] -- elements other than the last + -- should not contains BDPars + | BDSeparator -- semantically, space-unless-at-end-of-line. + | BDAddBaseY BrIndent BriDoc + | BDBaseYPushCur BriDoc + | BDBaseYPop BriDoc + | BDIndentLevelPushCur BriDoc + | BDIndentLevelPop BriDoc + | BDPar + { _bdpar_indent :: BrIndent + , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars + , _bdpar_indented :: BriDoc + } + -- | BDAddIndent BrIndent (BriDocF f) + -- | BDNewline + | BDAlt [BriDoc] + | BDForwardLineMode BriDoc + | BDExternal AnnKey + (Set AnnKey) -- set of annkeys contained within the node + -- to be printed via exactprint + Bool -- should print extra comment ? + Text + | BDPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) + | BDAnnotationPrior AnnKey BriDoc + | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc + | BDAnnotationRest AnnKey BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset + | BDLines [BriDoc] + | BDEnsureIndent BrIndent BriDoc + -- the following constructors are only relevant for the alt transformation + -- and are removed afterwards. They should never occur in any BriDoc + -- after the alt transformation. + | BDForceMultiline BriDoc + | BDForceSingleline BriDoc + | BDNonBottomSpacing Bool BriDoc + | BDSetParSpacing BriDoc + | BDForceParSpacing BriDoc + -- pseudo-deprecated + | BDDebug String BriDoc + deriving (Data.Data.Data, Eq, Ord) + +data BriDocF f + = -- BDWrapAnnKey AnnKey BriDoc + BDFEmpty + | BDFLit !Text + | BDFSeq [f (BriDocF f)] -- elements other than the last should + -- not contains BDPars. + | BDFCols ColSig [f (BriDocF f)] -- elements other than the last + -- should not contains BDPars + | BDFSeparator -- semantically, space-unless-at-end-of-line. + | BDFAddBaseY BrIndent (f (BriDocF f)) + | BDFBaseYPushCur (f (BriDocF f)) + | BDFBaseYPop (f (BriDocF f)) + | BDFIndentLevelPushCur (f (BriDocF f)) + | BDFIndentLevelPop (f (BriDocF f)) + | BDFPar + { _bdfpar_indent :: BrIndent + , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars + , _bdfpar_indented :: f (BriDocF f) + } + -- | BDAddIndent BrIndent (BriDocF f) + -- | BDNewline + | BDFAlt [f (BriDocF f)] + | BDFForwardLineMode (f (BriDocF f)) + | BDFExternal AnnKey + (Set AnnKey) -- set of annkeys contained within the node + -- to be printed via exactprint + Bool -- should print extra comment ? + Text + | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) + | BDFAnnotationPrior AnnKey (f (BriDocF f)) + | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) + | BDFAnnotationRest AnnKey (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset + | BDFLines [(f (BriDocF f))] + | BDFEnsureIndent BrIndent (f (BriDocF f)) + | BDFForceMultiline (f (BriDocF f)) + | BDFForceSingleline (f (BriDocF f)) + | BDFNonBottomSpacing Bool (f (BriDocF f)) + | BDFSetParSpacing (f (BriDocF f)) + | BDFForceParSpacing (f (BriDocF f)) + | BDFDebug String (f (BriDocF f)) + +-- deriving instance Data.Data.Data (BriDocF Identity) +deriving instance Data.Data.Data (BriDocF ((,) Int)) + +type BriDocFInt = BriDocF ((,) Int) +type BriDocNumbered = (Int, BriDocFInt) + +instance Uniplate.Uniplate BriDoc where + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x + uniplate (BDAnnotationPrior annKey bd) = + plate BDAnnotationPrior |- annKey |* bd + uniplate (BDAnnotationKW annKey kw bd) = + plate BDAnnotationKW |- annKey |- kw |* bd + uniplate (BDAnnotationRest annKey bd) = + plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw b bd) = + plate BDMoveToKWDP |- annKey |- kw |- b |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd + +newtype NodeAllocIndex = NodeAllocIndex Int + +-- TODO: rename to "dropLabels" ? +unwrapBriDocNumbered :: BriDocNumbered -> BriDoc +unwrapBriDocNumbered tpl = case snd tpl of + BDFEmpty -> BDEmpty + BDFLit t -> BDLit t + BDFSeq list -> BDSeq $ rec <$> list + BDFCols sig list -> BDCols sig $ rec <$> list + BDFSeparator -> BDSeparator + BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDFBaseYPop bd -> BDBaseYPop $ rec bd + BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDFPar ind line indented -> BDPar ind (rec line) (rec indented) + BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDFForwardLineMode bd -> BDForwardLineMode $ rec bd + BDFExternal k ks c t -> BDExternal k ks c t + BDFPlain t -> BDPlain t + BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd + BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd + BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd + BDFLines lines -> BDLines $ rec <$> lines + BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd + where rec = unwrapBriDocNumbered + +isNotEmpty :: BriDoc -> Bool +isNotEmpty BDEmpty = False +isNotEmpty _ = True + +-- this might not work. is not used anywhere either. +briDocSeqSpine :: BriDoc -> () +briDocSeqSpine = \case + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd + BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented + BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDPlain{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd + +briDocForceSpine :: BriDoc -> BriDoc +briDocForceSpine bd = briDocSeqSpine bd `seq` bd + + +data VerticalSpacingPar + = VerticalSpacingParNone -- no indented lines + | VerticalSpacingParSome Int -- indented lines, requiring this much + -- vertical space at most + | VerticalSpacingParAlways Int -- indented lines, requiring this much + -- vertical space at most, but should + -- be considered as having space for + -- any spacing validity check. + -- TODO: it might be wrong not to extend "always" to the none case, i.e. + -- we might get better properties of spacing operators by having a + -- product like (Normal|Always, None|Some Int). + deriving (Eq, Show) + +data VerticalSpacing + = VerticalSpacing + { _vs_sameLine :: !Int + , _vs_paragraph :: !VerticalSpacingPar + , _vs_parFlag :: !Bool + } + deriving (Eq, Show) + +newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) + deriving (Functor, Applicative, Monad, Show, Alternative) + +pattern LineModeValid :: forall t. t -> LineModeValidity t +pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t +pattern LineModeInvalid :: forall t. LineModeValidity t +pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.Brittany.Internal.Utils where + +import qualified Data.ByteString as B +import qualified Data.Coerce +import Data.Data +import Data.Generics.Aliases +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import DataTreePrint +import qualified GHC.Data.FastString as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Hs.Extension as HsExtension +import qualified GHC.OldList as List +import GHC.Types.Name.Occurrence as OccName (occNameString) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Outputable as GHC +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils +import qualified Text.PrettyPrint as PP + + + +parDoc :: String -> PP.Doc +parDoc = PP.fsep . fmap PP.text . List.words + +parDocW :: [String] -> PP.Doc +parDocW = PP.fsep . fmap PP.text . List.words . List.unwords + + +showSDoc_ :: GHC.SDoc -> String +showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags + +showOutputable :: (GHC.Outputable a) => a -> String +showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags + +fromMaybeIdentity :: Identity a -> Maybe a -> Identity a +fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y + +fromOptionIdentity :: Identity a -> Maybe a -> Identity a +fromOptionIdentity x y = + Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y + +-- maximum monoid over N+0 +-- or more than N, because Num is allowed. +newtype Max a = Max { getMax :: a } + deriving (Eq, Ord, Show, Bounded, Num) + +instance (Num a, Ord a) => Semigroup (Max a) where + (<>) = Data.Coerce.coerce (max :: a -> a -> a) + +instance (Num a, Ord a) => Monoid (Max a) where + mempty = Max 0 + mappend = (<>) + +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)++"}" + $ "{" ++ showOutputable ss ++ "}" + located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter + located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a + where + annStr = case cast ss of + Just (s :: GHC.SrcSpan) -> + ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) + Nothing -> ShowIsId "nnnnnnnn" + +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 (Semigroup.Last Bool)) + -> a + -> m () +traceIfDumpConf s accessor val = do + whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do + trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () + +tellDebugMess :: MonadMultiWriter + (Seq String) m => String -> m () +tellDebugMess s = mTell $ Seq.singleton s + +tellDebugMessShow :: forall a m . (MonadMultiWriter + (Seq String) m, Show a) => a -> m () +tellDebugMessShow = tellDebugMess . show + +-- i should really put that into multistate.. +mModify :: MonadMultiState s m => (s -> s) -> m () +mModify f = mGet >>= mSet . f + +astToDoc :: Data ast => ast -> PP.Doc +astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast + +briDocToDoc :: BriDoc -> PP.Doc +briDocToDoc = astToDoc . removeAnnotations + where + removeAnnotations = Uniplate.transform $ \case + BDAnnotationPrior _ x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x + +briDocToDocWithAnns :: BriDoc -> PP.Doc +briDocToDocWithAnns = astToDoc + +annsDoc :: ExactPrint.Types.Anns -> PP.Doc +annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) + +breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) +breakEither _ [] = ([], []) +breakEither fn (a1:aR) = case fn a1 of + Left b -> (b : bs, cs) + Right c -> (bs, c : cs) + where + (bs, cs) = breakEither fn aR + +spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) + where + (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) + +data FirstLastView a + = FirstLastEmpty + | FirstLastSingleton a + | FirstLast a [a] a + +splitFirstLast :: [a] -> FirstLastView a +splitFirstLast [] = FirstLastEmpty +splitFirstLast [x] = FirstLastSingleton x +splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) + +-- TODO: move to uniplate upstream? +-- aka `transform` +transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +transformUp f = g where g = f . Uniplate.descend g +_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +_transformDown f = g where g = Uniplate.descend g . f +transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x +_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x + +-- | similar to List.lines, but treating the case of final newline character +-- in such a manner that this function is the inverse of @intercalate "\n"@. +lines' :: String -> [String] +lines' s = case break (== '\n') s of + (s1, []) -> [s1] + (s1, [_]) -> [s1, ""] + (s1, (_:r)) -> s1 : lines' r + +absurdExt :: HsExtension.NoExtCon -> a +absurdExt = HsExtension.noExtCon diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs new file mode 100644 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Main where + +import Control.Monad (zipWithM) +import qualified Control.Monad.Trans.Except as ExceptT +import Data.CZipWith +import qualified Data.Either +import qualified Data.List.Extra +import qualified Data.Monoid +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import DataTreePrint +import GHC (GenLocated(L)) +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC +import qualified GHC.OldList as List +import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Obfuscation +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Paths_brittany +import qualified System.Directory as Directory +import qualified System.Environment as Environment +import qualified System.Exit +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.PrettyPrint as PP +import Text.Read (Read(..)) +import UI.Butcher.Monadic + + + +data WriteMode = Display | Inplace + +instance Read WriteMode where + readPrec = val "display" Display <|> val "inplace" Inplace + where val iden v = ReadPrec.lift $ ReadP.string iden >> return v + +instance Show WriteMode where + show Display = "display" + show Inplace = "inplace" + + +main :: IO () +main = do + progName <- Environment.getProgName + args <- Environment.getArgs + mainWith progName args + +mainWith :: String -> [String] -> IO () +mainWith progName args = + Environment.withProgName progName + . Environment.withArgs args + $ mainFromCmdParserWithHelpDesc mainCmdParser + +helpDoc :: PP.Doc +helpDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDocW + [ "Reformats one or more haskell modules." + , "Currently affects only the module head (imports/exports), type" + , "signatures and function bindings;" + , "everything else is left unmodified." + , "Based on ghc-exactprint, thus (theoretically) supporting all" + , "that ghc does." + ] + , parDoc $ "Example invocations:" + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany" + , PP.nest 2 $ PP.text "read from stdin, output to stdout" + ] + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" + , PP.nest 2 $ PP.vcat + [ PP.text "run on all modules in current directory (no backup!)" + , PP.text "4 spaces indentation" + ] + ] + , parDocW + [ "This program is written carefully and contains safeguards to ensure" + , "the output is syntactically valid and that no comments are removed." + , "Nonetheless, this is a young project, and there will always be bugs," + , "and ensuring that the transformation never changes semantics of the" + , "transformed source is currently not possible." + , "Please do check the output and do not let brittany override your large" + , "codebase without having backups." + ] + , parDoc $ "There is NO WARRANTY, to the extent permitted by law." + , parDocW + [ "This program is free software released under the AGPLv3." + , "For details use the --license flag." + ] + , parDoc $ "See https://github.com/lspitzner/brittany" + , parDoc + $ "Please report bugs at" + ++ " https://github.com/lspitzner/brittany/issues" + ] + +licenseDoc :: PP.Doc +licenseDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" + , parDoc $ "Copyright (C) 2019 PRODA LTD" + , parDocW + [ "This program is free software: you can redistribute it and/or modify" + , "it under the terms of the GNU Affero General Public License," + , "version 3, as published by the Free Software Foundation." + ] + , parDocW + [ "This program is distributed in the hope that it will be useful," + , "but WITHOUT ANY WARRANTY; without even the implied warranty of" + , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , "GNU Affero General Public License for more details." + ] + , parDocW + [ "You should have received a copy of the GNU Affero General Public" + , "License along with this program. If not, see" + , "." + ] + ] + + +mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () +mainCmdParser helpDesc = do + addCmdSynopsis "haskell source pretty printer" + addCmdHelp $ helpDoc + -- addCmd "debugArgs" $ do + addHelpCommand helpDesc + addCmd "license" $ addCmdImpl $ print $ licenseDoc + -- addButcherDebugCommand + reorderStart + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] mempty + noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty + configPaths <- addFlagStringParams "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser + 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]") + checkMode <- addSimpleBoolFlag + "c" + ["check-mode"] + (flagHelp + (PP.vcat + [ PP.text "check for changes but do not write them out" + , PP.text "exits with code 0 if no changes necessary, 1 otherwise" + , PP.text "and print file path(s) of files that have changes to stdout" + ] + ) + ) + writeMode <- addFlagReadParam + "" + ["write-mode"] + "(display|inplace)" + ( flagHelp + (PP.vcat + [ PP.text "display: output for any input(s) goes to stdout" + , PP.text "inplace: override respective input file (without backup!)" + ] + ) + Data.Monoid.<> flagDefault Display + ) + inputParams <- addParamNoFlagStrings + "PATH" + (paramHelpStr "paths to input/inout haskell source files") + reorderStop + addCmdImpl $ void $ do + when printLicense $ do + print licenseDoc + System.Exit.exitSuccess + when printVersion $ do + do + putStrLn $ "brittany version " ++ showVersion version + putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" + putStrLn $ "Copyright (C) 2019 PRODA LTD" + putStrLn $ "There is NO WARRANTY, to the extent permitted by law." + System.Exit.exitSuccess + when printHelp $ do + liftIO + $ putStrLn + $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } + $ ppHelpShallow helpDesc + System.Exit.exitSuccess + + let inputPaths = + if null inputParams then [Nothing] else map Just inputParams + let outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths + + configsToLoad <- liftIO $ if null configPaths + then + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- + runMaybeT + (if noUserConfig + then readConfigs cmdlineConfig configsToLoad + else readConfigsWithUserConfig cmdlineConfig configsToLoad + ) + >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + when (config & _conf_debug & _dconf_dump_config & confUnpack) + $ trace (showConfigYaml config) + $ return () + + results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths + + if checkMode + then when (Changes `elem` (Data.Either.rights results)) + $ System.Exit.exitWith (System.Exit.ExitFailure 1) + else case results of + xs | all Data.Either.isRight xs -> pure () + [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + + +data ChangeStatus = Changes | NoChanges + deriving (Eq) + +-- | The main IO parts for the default mode of operation, and after commandline +-- and config stuff is processed. +coreIO + :: (String -> IO ()) -- ^ error output function. In parallel operation, you + -- may want serialize the different outputs and + -- consequently not directly print to stderr. + -> Config -- ^ global program config. + -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so + -- currently not part of program config. + -> Bool -- ^ whether we are (just) in check mode. + -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. + -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. + -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. +coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = + ExceptT.runExceptT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + -- there is a good of code duplication between the following code and the + -- `pureModuleTransform` function. Unfortunately, there are also a good + -- amount of slight differences: This module is a bit more verbose, and + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- the flag will do the following: insert a marker string + -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + -- The flag is intentionally misspelled to prevent clashing with + -- inline-config stuff. + let hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + (parseResult, originalContents) <- case inputPathM of + Nothing -> do + -- TODO: refactor this hack to not be mixed into parsing logic + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id + inputString <- liftIO System.IO.getContents + parseRes <- liftIO $ parseModuleFromString ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) + return (parseRes, Text.pack inputString) + Just p -> liftIO $ do + parseRes <- parseModule ghcOptions p cppCheckFunc + inputText <- Text.IO.readFile p + -- The above means we read the file twice, but the + -- GHC API does not really expose the source it + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> + -- handle still open -> write below crashes - evil.) + return (parseRes, inputText) + case parseResult of + Left left -> do + putErrorLn "parse error:" + putErrorLn left + ExceptT.throwE 60 + Right (anns, parsedSource, hasCPP) -> do + (inlineConf, perItemConf) <- + case + extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + of + Left (err, input) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + ExceptT.throwE 61 + Right c -> -- trace (showTree c) $ + pure c + let moduleConf = cZipWith fromOptionIdentity config inlineConf + when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + let disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack + (errsWarns, outSText, hasChanges) <- do + if + | disableFormatting -> do + pure ([], originalContents, False) + | exactprintOnly -> do + let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + pure ([], r, r /= originalContents) + | otherwise -> do + let omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return + $ pPrintModule moduleConf perItemConf anns parsedSource + else liftIO $ pPrintModuleAndCheck moduleConf + perItemConf + anns + parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + else outRaw + out' <- if moduleConf & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out', out' /= originalContents) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 + unless (null errsWarns) $ do + let groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns + groupedErrsWarns `forM_` \case + (ErrorOutputCheck{} : _) -> do + putErrorLn + $ "ERROR: brittany pretty printer" + ++ " returned syntactically invalid result." + (ErrorInput str : _) -> do + putErrorLn $ "ERROR: parse error: " ++ str + uns@(ErrorUnknownNode{} : _) -> do + putErrorLn + $ "WARNING: encountered unknown syntactical constructs:" + uns `forM_` \case + ErrorUnknownNode str ast@(L loc _) -> do + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) + when + ( config + & _conf_debug + & _dconf_dump_ast_unknown + & confUnpack + ) + $ do + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + putErrorLn + " -> falling back on exactprint for this element of the module" + warns@(LayoutWarning{} : _) -> do + putErrorLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putErrorLn str + _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComment{} : _) -> do + putErrorLn + $ "Error: detected unprocessed comments." + ++ " The transformation output will most likely" + ++ " not contain some of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> error "cannot happen (TM)" + (ErrorMacroConfig err input : _) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let + hasErrors = + if config & _conf_errorHandling & _econf_Werror & confUnpack + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) + outputOnErrs = + config + & _conf_errorHandling + & _econf_produceOutputOnErrors + & confUnpack + shouldOutput = + not suppressOutput + && not checkMode + && (not hasErrors || outputOnErrs) + + when shouldOutput + $ addTraceSep (_conf_debug config) + $ case outputPathM of + Nothing -> liftIO $ Text.IO.putStr $ outSText + Just p -> liftIO $ do + let isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges + unless isIdentical $ Text.IO.writeFile p $ outSText + + when (checkMode && hasChanges) $ case inputPathM of + Nothing -> pure () + Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p + + when hasErrors $ ExceptT.throwE 70 + return (if hasChanges then Changes else NoChanges) + where + addTraceSep conf = + if or + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] + then trace "----" + else id diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/source/test-suite/Main.hs @@ -0,0 +1,37 @@ +import qualified Control.Monad as Monad +import qualified Data.List as List +import qualified Language.Haskell.Brittany.Main as Brittany +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified Test.Hspec as Hspec + +main :: IO () +main = Hspec.hspec . Hspec.parallel $ do + let directory = "data" + entries <- Hspec.runIO $ Directory.listDirectory directory + Monad.forM_ (List.sort entries) $ \entry -> + case FilePath.stripExtension "hs" entry of + Nothing -> pure () + Just slug -> Hspec.it slug $ do + let input = FilePath.combine directory entry + expected <- readFile input + let output = FilePath.combine "output" entry + Directory.copyFile input output + Brittany.mainWith + "brittany" + [ "--config-file" + , FilePath.combine directory "brittany.yaml" + , "--no-user-config" + , "--write-mode" + , "inplace" + , output + ] + actual <- readFile output + Literal actual `Hspec.shouldBe` Literal expected + +newtype Literal + = Literal String + deriving Eq + +instance Show Literal where + show (Literal x) = x diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs deleted file mode 100644 --- a/src-brittany/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified Language.Haskell.Brittany.Main as BrittanyMain - -main :: IO () -main = BrittanyMain.main diff --git a/src-libinterfacetests/Main.hs b/src-libinterfacetests/Main.hs deleted file mode 100644 --- a/src-libinterfacetests/Main.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Main where - - - -import Test.Hspec -import Language.Haskell.Brittany -import qualified Data.Text as Text -import qualified System.Exit as Exit -import Control.Monad.IO.Class - - - -main :: IO () -main = hspec $ do - describe "library interface basic functionality" $ do - it "gives properly formatted result for valid input" $ do - let - input = Text.pack $ unlines - ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] - let expected = Text.pack $ unlines - [ "func =" - , " [ 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " ]" - ] - output <- liftIO $ parsePrintModule staticDefaultConfig input - input `shouldSatisfy` \_ -> case output of - Right x | x == expected -> True - _ -> False - diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt deleted file mode 100644 --- a/src-literatetests/10-tests.blt +++ /dev/null @@ -1,1630 +0,0 @@ - -############################################################################### -############################################################################### -############################################################################### -#group type signatures -############################################################################### -############################################################################### -############################################################################### - -#test simple001 -func :: a -> a - -#test long typeVar -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test keep linebreak mode -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - -#test simple parens 1 -func :: ((a)) - -#test simple parens 2 -func :: (a -> a) -> a - -#test simple parens 3 -func :: a -> (a -> a) - -#test did anyone say parentheses? -func :: (((((((((()))))))))) - --- current output is.. funny. wonder if that can/needs to be improved.. -#test give me more! -#pending -func :: ((((((((((((((((((((((((((((((((((((((((((())))))))))))))))))))))))))))))))))))))))))) - -#test unit -func :: () - - -############################################################################### - -#test paren'd func 1 -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - ) - -#test paren'd func 2 -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) - -#test paren'd func 3 -func - :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) - -> lakjsdlkjasldkj - -#test paren'd func 4 -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> lakjsdlkjasldkj - -#test paren'd func 5 -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) - -############################################################################### - -#test type application 1 -func :: asd -> Either a b - -#test type application 2 -func - :: asd - -> Either - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test type application 3 -func - :: asd - -> Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test type application 4 -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd - -#test type application 5 -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) - -#test type application 6 -func - :: Trither - asd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -#test type application paren 1 -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -#test type application paren 2 -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test type application paren 3 -func - :: ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd - -############################################################################### - -#test list simple -func :: [a -> b] - -#test list func -func - :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ] - -#test list paren -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] - -################################################################## -- ############# - -#test tuple type 1 -func :: (a, b, c) - -#test tuple type 2 -func :: ((a, b, c), (a, b, c), (a, b, c)) - -#test tuple type long -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -#test tuple type nested -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) - -#test tuple type function -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] -############################################################################### -#test type operator stuff -#pending -test050 :: a :+: b -test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -############################################################################### - -#test forall oneliner -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b - -#test forall context multiline -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . Foo - => ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () - -#test forall no-context multiline -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () - -#test forall context multiline with comments -{-# LANGUAGE RankNTypes #-} -addFlagStringParam - :: forall f out - . (Applicative f) - => String -- ^ short flag chars, i.e. "v" for -v - -> [String] -- ^ list of long names, i.e. ["verbose"] - -> String -- ^ param name - -> Flag String -- ^ properties - -> CmdParser f out String - -#test language pragma issue -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b - -#test comments 1 -func :: a -> b -- comment - -#test comments 2 -funcA :: a -> b -- comment A -funcB :: a -> b -- comment B - -#test comments all -#pending --- a -func -- b - :: -- c - a -- d - -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j --- k - - -############################################################################### -############################################################################### -############################################################################### -#group type signatures pragmas -############################################################################### -############################################################################### -############################################################################### - -#test inline pragma 1 -func = f - where - {-# INLINE f #-} - f = id - -#test inline pragma 2 -func = ($) - where - {-# INLINE ($) #-} - ($) = id - -#test inline pragma 3 -func = f - where - {-# INLINE CONLIKE [1] f #-} - f = id - -#test noinline pragma 1 -{-# NOINLINE func #-} -func :: Int - -#test inline pragma 4 -#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2. -func = f - where - {-# INLINE [~] f #-} - f = id - - -############################################################################### -############################################################################### -############################################################################### -#group data type declarations -############################################################################### -############################################################################### -############################################################################### - -#test nullary data type -data Foo = Bar {} - -data Biz = Baz - -#test single record -data Foo = Bar - { foo :: Baz - } - -#test record multiple names -data Foo = Bar - { foo, bar :: Baz - } - -#test record multiple types -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -#test record multiple types and names -data Foo = Bar - { foo, biz :: Baz - , bar :: Bizzz - } - -#test record multiple types deriving -data Foo = Bar - { fooz :: Baz - , bar :: Bizzz - } - deriving Show - -#test record long field names -data MyRecord = MyConstructor - { bar1, bar2 - :: Loooooooooooooooooooooooooooooooong - -> Loooooooooooooooooooooooooooooooong - , foo1, foo2 - :: Loooooooooooooooooooooooooooooooonger - -> Loooooooooooooooooooooooooooooooonger - } - -#test record with DataTypeContexts -{-# LANGUAGE DatatypeContexts #-} -data - ( LooooooooooooooooooooongConstraint a - , LooooooooooooooooooooongConstraint b - ) => - MyRecord a b - = MyConstructor - { foo1, foo2 - :: loooooooooooooooooooooooooooooooong - -> loooooooooooooooooooooooooooooooong - , bar :: a - , bazz :: b - } - -#test record single line layout -#pending config flag is disabled for now -{-# LANGUAGE ScopedTypeVariables #-} --- brittany { lconfig_allowSinglelineRecord: true } -data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int } - -#test record no matching single line layout -{-# LANGUAGE ScopedTypeVariables #-} --- brittany { lconfig_allowSinglelineRecord: true } -data MyRecord = forall a . Show a => Bar - { foo :: abittoolongbutnotvery -> abittoolongbutnotvery - } - -#test record forall constraint multiline -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a - . LooooooooooooooooooooongConstraint a => - LoooooooooooongConstructor - { foo :: abittoolongbutnotvery -> abittoolongbutnotvery - } - -#test record forall constraint multiline more -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor - { a :: a - , b :: b - } - -#test plain with forall and constraint -{-# LANGUAGE ScopedTypeVariables #-} -data MyStruct - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor (ToBriDocM BriDocNumbered) - (ToBriDocM BriDocNumbered) - (ToBriDocM BriDocNumbered) - -#test record with many features -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor - { foo, foo2 - :: loooooooooooooooooooooooooooooooong - -> loooooooooooooooooooooooooooooooong - , bar :: a - , bazz :: b - } - deriving Show - -#test record multiple types deriving -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) - -#test record multiple deriving strategies -#min-ghc 8.2 -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving Show - deriving (Eq, Ord) - deriving stock Show - deriving stock (Eq, Ord) - deriving anyclass Show - deriving anyclass (Show, Eq, Monad, Functor) - deriving newtype Show - deriving newtype (Traversable, Foldable) - -#test record deriving via -#min-ghc 8.6 -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving ToJSON via (SomeType) - deriving (ToJSON, FromJSON) via (SomeType) - -#test single record existential -{-# LANGUAGE ExistentialQuantification #-} - -data Foo = forall a . Show a => Bar - { foo :: a - } - -#test record multiple types existential -{-# LANGUAGE ExistentialQuantification #-} - -data Foo = forall a b . (Show a, Eq b) => Bar - { foo :: a - , bars :: b - } - -#test plain comment simple --- before -data MyData = MyData Int --- after - -#test record newline comment -data MyRecord = MyRecord - { a :: Int - -- comment - , b :: Int - } - -#test record comments simple -data Foo = Bar -- a - { foo :: Baz -- b - , bars :: Bizzz -- c - } -- d - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e - -#test record comments strange inline -data Foo = Bar - { -- a - foo -- b - :: -- c - Baz -- d - , -- e - bars :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) - -#test record comments in deriving -## maybe we want to switch to a differnt layout when there are such comments. -## Don't hesitate to modify this testcase, it clearly is not the ideal layout -## for this. - -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -- a - deriving --b - ( -- c - ToJSON -- d - , -- e - FromJSON --f - ) -- g - -#test record comments in deriving via -## maybe we want to switch to a differnt layout when there are such comments. -## Don't hesitate to modify this testcase, it clearly is not the ideal layout -## for this. -#min-ghc 8.6 - -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -- a - deriving --a - ToJSON --b - via -- c - ( -- d - SomeType --e - , -- f - ABC --g - ) - -#test comment before equal sign -{-# LANGUAGE ExistentialQuantification #-} -data MyRecord - -- test comment - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor a b - -#test normal records on multi line indent policy left --- brittany {lconfig_indentPolicy: IndentPolicyLeft } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] - -#test normal records on multi line indent policy free --- brittany {lconfig_indentPolicy: IndentPolicyFree } -data GrantsForCompanyResp = GrantsForCompanyResp Types.Company - [EnterpriseGrantResponse] - -#test normal records on multi line indent policy free 2 --- brittany {lconfig_indentPolicy: IndentPolicyFree } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] - -#test normal records on multi line indent policy multiple --- brittany {lconfig_indentPolicy: IndentPolicyMultiple } -data GrantsForCompanyResp = GrantsForCompanyResp Types.Company - [EnterpriseGrantResponse] - -#test large record with a comment -data XIILqcacwiuNiu = XIILqcacwiuNiu - { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo - , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] - , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo - , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo - , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int - , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq - , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq - , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo - , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn - , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo - , opjUxtkxzkiKse_luqjuZazt - :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] - -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () - , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo - , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn - , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn - , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn - , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn - , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep - , jeyOcuesexaYoy_vpqn :: Jgtoyuh () - } - -############################################################################### -############################################################################### -############################################################################### -#group equation.basic -############################################################################### -############################################################################### -############################################################################### -## 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.) - -#test basic 1 -func x = x - -#test infix 1 -x *** y = x - -#test symbol prefix -(***) x y = x - -#test infix more args simple -(f >=> g) k = f k >>= g - -#test infix more args alignment -(Left a <$$> Left dd) e f = True -(Left a <$$> Right d ) e f = True -(Right a <$$> Left d ) e f = False -(Right a <$$> Right dd) e f = True - - -############################################################################### -############################################################################### -############################################################################### -#group equation.patterns -############################################################################### -############################################################################### -############################################################################### - -#test wildcard -func _ = x - -#test simple long pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - -#test simple multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - -#test another multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - a - b - = x - -#test simple constructor -func (A a) = a - -#test list constructor -func (x : xr) = x - -#test some other constructor symbol -#pending -func (x :+: xr) = x - -#test normal infix constructor -func (x `Foo` xr) = x - - -############################################################################### -############################################################################### -############################################################################### -#group equation.guards -############################################################################### -############################################################################### -############################################################################### -#test simple guard -func | True = x - -#test multiple-clauses-1 -func x | x = simple expression - | otherwise = 0 - -#test multiple-clauses-2 -func x - | a somewhat longer guard x = "and a somewhat longer expession that does not" - | otherwise = "fit without putting the guards in new lines" - -#test multiple-clauses-3 -func x - | very long guard, another rather long guard that refers to x = nontrivial - expression - foo - bar - alsdkjlasdjlasj - | otherwise = 0 - -#test multiple-clauses-4 -func x - | very long guard, another rather long guard that refers to x - = nontrivialexpression foo bar alsdkjlasdjlasj - | otherwise - = 0 - -#test multiple-clauses-5 -func x - | very loooooooooooooooooooooooooooooong guard - , another rather long guard that refers to x - = nontrivial expression foo bar alsdkjlasdjlasj - | otherwise - = 0 - - -############################################################################### -############################################################################### -############################################################################### -#group expression.basic -############################################################################### -############################################################################### -############################################################################### - -#test var -func = x - -describe "infix op" $ do -#test 1 -func = x + x - -#test long -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test long keep linemode 1 -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - -#test long keep linemode 2 -#pending -func = mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test literals -func = 1 -func = "abc" -func = 1.1e5 -func = 'x' -func = 981409823458910394810928414192837123987123987123 - -#test lambda -func = \x -> abc - -describe "app" $ do -#test 1 -func = klajsdas klajsdas klajsdas - -#test 2 -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - -#test 3 -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas - lakjsdlajsdljas - lakjsdlajsdljas - -### -#group expression.basic.sections -### - -#test left -func = (1 +) - -#test right -func = (+ 1) - -#test left inf -func = (1 `abc`) - -#test right inf -func = (`abc` 1) - -### -#group tuples -### - -#test pair -func = (abc, def) - -#test pair section left -func = (abc, ) - -#test pair section right -func = (, abc) - -#test quintuple section long -myTupleSection = - ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement - , - , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement - , - ) - -#test 2 -#pending -func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) - -#test comment-after-then -foo = if True - then - -- iiiiii - "a " - else - "b " - -#test comment-after-if-else-do -func = if cond - then pure 42 - else do - -- test - abc - -#test nonempty-case-short -func = case x of - False -> False - True -> True - -#test nonempty-case-long -func = - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of - False -> False - True -> True - -#test nonempty-case-long-do -func = do - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of - False -> False - True -> True - -#test empty-case-short -func = case x of {} - -#test empty-case-long -func = - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of {} - -#test empty-case-long-do -func = do - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of {} - -############################################################################### -############################################################################### -############################################################################### -#group expression.do statements -############################################################################### -############################################################################### -############################################################################### - -#test simple -func = do - stmt - stmt - -#test bind -func = do - x <- stmt - stmt x - -#test let -func = do - let x = 13 - stmt x - - -############################################################################### -############################################################################### -############################################################################### -#group expression.lists -############################################################################### -############################################################################### -############################################################################### - -#test monad-comprehension-case-of -func = - foooooo - $ [ case - foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - of - _ -> True - ] - -############################################################################### -############################################################################### -############################################################################### -#group expression.let -############################################################################### -############################################################################### -############################################################################### - -#test single-bind-comment-long -testMethod foo bar baz qux = - let x = undefined foo bar baz qux qux baz bar :: String - -- some comment explaining the in expression - in undefined foo x :: String - -#test single-bind-comment-short -testMethod foo bar baz qux = - let x = undefined :: String - -- some comment explaining the in expression - in undefined :: String - -#test single-bind-comment-before -testMethod foo bar baz qux = - -- some comment explaining the in expression - let x = undefined :: String in undefined :: String - -#test multiple-binds-comment -foo foo bar baz qux = - let a = 1 - b = 2 - c = 3 - -- some comment explaining the in expression - in undefined :: String - - -############################################################################### -############################################################################### -############################################################################### -#group stylisticspecialcases -############################################################################### -############################################################################### -############################################################################### - -#test operatorprefixalignment-even-with-multiline-alignbreak -func = - foo - $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - ] - ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] - - -############################################################################### -############################################################################### -############################################################################### -#group module -############################################################################### -############################################################################### -############################################################################### - -#test simple -module Main where - -#test no-exports -module Main () where - -#test one-export -module Main (main) where - -#test several-exports -module Main (main, test1, test2) where - -#test many-exports -module Main - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) where - -#test exports-with-comments -module Main - ( main - -- main - , test1 - , test2 - -- Test 3 - , test3 - , test4 - -- Test 5 - , test5 - -- Test 6 - ) where - -#test simple-export-with-things -module Main (Test(..)) where - -#test simple-export-with-module-contents -module Main (module Main) where - -#test export-with-things -module Main (Test(Test, a, b)) where - -#test export-with-things-comment --- comment1 - -module Main - ( Test(Test, a, b) - , foo -- comment2 - ) -- comment3 - where - -#test export-with-empty-thing -module Main (Test()) where - -#test empty-with-comment --- Intentionally left empty - -############################################################################### -############################################################################### -############################################################################### -#group module.import -############################################################################### -############################################################################### -############################################################################### - -#test simple-import -import Data.List - -#test simple-import-alias -import Data.List as L - -#test simple-qualified-import -import qualified Data.List - -#test simple-qualified-import-alias -import qualified Data.List as L - -#test simple-safe -import safe Data.List as L - -#test simple-source -import {-# SOURCE #-} Data.List ( ) - -#test simple-safe-qualified -import safe qualified Data.List - -#test simple-safe-qualified-source -import {-# SOURCE #-} safe qualified Data.List - -#test simple-qualified-package -import qualified "base" Data.List - -#test qualifier-effect -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List ( ) -import {-# SOURCE #-} safe qualified Data.List hiding ( ) - -#test instances-only -import qualified Data.List ( ) - -#test one-element -import Data.List ( nub ) - -#test several-elements -import Data.List ( foldl' - , indexElem - , nub - ) - -#test a-ridiculous-amount-of-elements -import Test ( Long - , anymore - , fit - , items - , line - , list - , not - , onA - , quite - , single - , that - , will - , with - ) - -#test with-things -import Test ( (+) - , (:!)(..) - , (:*)((:.), T7, t7) - , (:.) - , T - , T2() - , T3(..) - , T4(T4) - , T5(T5, t5) - , T6((<|>)) - ) - -#test hiding -import Test hiding ( ) -import Test as T - hiding ( ) - -#test import-hiding-many -import Prelude as X - hiding ( head - , init - , last - , maximum - , minimum - , pred - , read - , readFile - , succ - , tail - , undefined - ) - -#test long-module-name-simple -import TestJustAbitToLongModuleNameLikeThisOneIs - ( ) -import TestJustShortEnoughModuleNameLikeThisOne ( ) - -#test long-module-name-as -import TestJustAbitToLongModuleNameLikeThisOneI - as T -import TestJustShortEnoughModuleNameLikeThisOn as T - -#test long-module-name-hiding -import TestJustAbitToLongModuleNameLikeTh - hiding ( ) -import TestJustShortEnoughModuleNameLike hiding ( ) - -#test long-module-name-simple-items -import MoreThanSufficientlyLongModuleNameWithSome - ( compact - , fit - , inA - , items - , layout - , not - , that - , will - ) - -#test long-module-name-hiding-items -import TestJustAbitToLongModuleNameLikeTh - hiding ( abc - , def - , ghci - , jklm - ) -import TestJustShortEnoughModuleNameLike hiding ( abc - , def - , ghci - , jklm - ) - -#test long-module-name-other -import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) -import {-# SOURCE #-} safe qualified "qualifiers" A - hiding ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff - as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe - ( ) - -#test import-with-comments --- Test -import Data.List ( nub ) -- Test -{- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} - --- Test -import Test ( test ) - -#test import-with-comments-2 - -import Test ( abc - , def - -- comment - ) - -#test import-with-comments-3 - -import Test ( abc - -- comment - ) - -#test import-with-comments-4 -import Test ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) - -#test import-with-comments-5 -import Test ( -- comment - ) - -#test long-bindings -import Test ( longbindingNameThatoverflowsColum - ) -import Test ( Long - ( List - , Of - , Things - ) - ) - -#test things-with-with-comments -import Test ( Thing - ( -- Comments - ) - ) -import Test ( Thing - ( Item - -- and Comment - ) - ) -import Test ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) -#test prefer-dense-empty-list -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine - ( ) - -#test preamble full-preamble -{-# LANGUAGE BangPatterns #-} - -{- - - Test module - -} -module Test - ( test1 - -- ^ test - , test2 - -- | test - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - -- Test 10 - ) where - --- Test -import Data.List ( nub ) -- Test -{- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} - --- Test -import Test ( test ) - -#test sorted-imports -import Aaa -import Baa - -#test sorted-import-groups -import Zaa -import Zab - -import Aaa -import Baa - -#test sorted-qualified-imports -import Boo -import qualified Zoo - -#test imports-groups-same-module -import Boo ( a ) - -import Boo ( b ) - -#test sorted-imports-nested -import A.B.C -import A.B.D - -############################################################################### -############################################################################### -############################################################################### -#group type synonyms -############################################################################### -############################################################################### -############################################################################### - -#test simple-synonym - -type MySynonym = String - -#test parameterised-synonym - -type MySynonym a = [a] - -#test long-function-synonym - --- | Important comment thrown in -type MySynonym b a - = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b - -#test overflowing-function-synonym - -type MySynonym3 b a - = MySynonym a b - -> MySynonym a b - -- ^ RandomComment - -> MyParamType a b - -> MyParamType a b - -> MySynonym2 b a - -#test synonym-with-kind-sig - -type MySynonym (a :: * -> *) - = MySynonym a b - -> MySynonym a b - -> MyParamType a b - -> MyParamType a b - -> MySynonym2 b a - -#test synonym-with-constraint - -type MySynonym a = Num a => a -> Int - -#test synonym-overflowing-with-constraint - -type MySynonym a - = Num a - => AReallyLongTypeName - -> AnotherReallyLongTypeName - -> AThirdTypeNameToOverflow - -#test synonym-forall - -{-# LANGUAGE RankNTypes #-} - -type MySynonym = forall a . [a] - -#test synonym-operator - -type (:+:) a b = (a, b) - -#test synonym-infix - -type a `MySynonym` b = a -> b - -#test synonym-infix-operator - -type a :+: b = (a, b) - -#test synonym-infix-parens - -type (a `Foo` b) c = (a, b, c) - -#test synonym-comments - -type Foo a -- fancy type comment - = -- strange comment - Int - -#test synonym-type-operators -#pending - -type (a :+: b) = (a, b) - -#test synonym-multi-parens -#pending - -type ((a :+: b) c) = (a, c) - -#test synonym-tuple-type-many-comments - -type Foo - = ( -- t1 - A -- t2 - , -- t3 - B -- t4 - ) -- t5 - -############################################################################### -############################################################################### -############################################################################### -#group class.instance -############################################################################### -############################################################################### -############################################################################### - -#test simple-instance - -instance MyClass Int where - myMethod x = x + 1 - -#test simple-method-comment - -instance MyClass Int where - myMethod x = - -- insightful comment - x + 1 - -#test simple-method-signature - -instance MyClass Int where - myMethod :: Int -> Int - myMethod x = x + 1 - -#test simple-long-method-signature - -instance MyClass Int where - myMethod - :: Int - -> Int - -> AReallyLongType - -> AReallyLongType - -> AReallyLongType - -> Int - myMethod x = x + 1 - -#test simple-two-methods - -instance MyClass Int where - myMethod x = x + 1 - myMethod2 x = x + 1 - -#test simple-two-signatures - -instance MyClass Int where - myMethod - :: Int - -> Int - -> AReallyLongType - -> AReallyLongType - -> AReallyLongType - -> Int - myMethod x = x + 1 - - myMethod2 :: Int -> Int - myMethod2 x = x + 1 - -#test simple-instance-comment - --- | This instance should be commented on -instance MyClass Int where - - -- | This method is also comment-worthy - myMethod x = x + 1 - -#test instance-with-type-family - -instance MyClass Int where - type MyType = Int - - myMethod :: MyType -> Int - myMethod x = x + 1 - -#test instance-with-type-family-below-method - -instance MyClass Int where - - type MyType = String - - myMethod :: MyType -> Int - myMethod x = x + 1 - - type MyType = Int - -#test instance-with-data-family - -instance MyClass Int where - - -- | This data is very important - data MyData = IntData - { intData :: String - , intData2 :: Int - } - - myMethod :: MyData -> Int - myMethod = intData2 - -#test instance-with-data-family-below-method - -instance MyClass Int where - -- | This data is important - data MyData = Test Int Int - - myMethod :: MyData -> Int - myMethod = intData2 - - -- | This data is also important - data MyData2 = IntData - { intData :: String - -- ^ Interesting field - , intData2 :: Int - } - -#test instance-with-newtype-family-and-deriving - -{-# LANGUAGE TypeFamilies #-} - -module Lib where - -instance Foo () where - newtype Bar () = Baz () - deriving (Eq, Ord, Show) - bar = Baz - -#test instance-with-newtype-family-and-record - -instance Foo Int where - newtype Bar Int = BarInt - { unBarInt :: Int - } - - -############################################################################### -############################################################################### -############################################################################### -#group whitespace-newlines -############################################################################### -############################################################################### -############################################################################### - -#test module-import-newlines - -module Main where - -import Prelude - -firstDecl = True - -#test function-where-newlines - -func = do - - -- complex first step - aaa - - -- complex second step - bbb - - where - - helper :: Helper - helper = helpful - - other :: Other - other = True - - -############################################################################### -############################################################################### -############################################################################### -#group typefam.instance -############################################################################### -############################################################################### -############################################################################### - -#test simple-typefam-instance - -type instance MyFam Bool = String - -#test simple-typefam-instance-param-type - -type instance MyFam (Maybe a) = a -> Bool - -#test simple-typefam-instance-parens -#pending the parens cause problems since ghc-8.8 - -type instance (MyFam (String -> Int)) = String - -#test simple-typefam-instance-overflow - -type instance MyFam ALongishType - = AMuchLongerTypeThanThat - -> AnEvenLongerTypeThanTheLastOne - -> ShouldDefinitelyOverflow - -#test simple-typefam-instance-comments - --- | A happy family -type instance MyFam Bool -- This is an odd one - = AnotherType -- Here's another - -#test simple-typefam-instance-parens-comment -#pending the parens cause problems since ghc-8.8 - --- | A happy family -type instance (MyFam Bool) -- This is an odd one - = -- Here's another - AnotherType diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt deleted file mode 100644 --- a/src-literatetests/14-extensions.blt +++ /dev/null @@ -1,242 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group extensions -############################################################################### -############################################################################### -############################################################################### - -############################################################################### -## MultiWayIf -#test multiwayif 1 -{-# LANGUAGE MultiWayIf #-} -func = if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - -#test multiwayif 2 -{-# LANGUAGE MultiWayIf #-} -func = do - foo - bar $ if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - - -############################################################################### -## LambdaCase -#test lambdacase 1 -{-# LANGUAGE LambdaCase #-} -func = \case - FooBar -> x - Baz -> y - - - -############################################################################### -## ImplicitParams -#test ImplicitParams 1 -{-# LANGUAGE ImplicitParams #-} -func :: (?asd::Int) -> () - -#test ImplicitParams 2 -{-# LANGUAGE ImplicitParams #-} -func - :: ( ?asd - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> () - - -############################################################################### -## RecursiveDo -#test recursivedo 1 -{-# LANGUAGE RecursiveDo #-} -foo = do - rec a <- f b - b <- g a - return (a, b) - -#test recursivedo 2 -{-# LANGUAGE RecursiveDo #-} -foo = do - rec -- comment - a <- f b - b <- g a - return (a, b) - -############################################################################### -## ExplicitNamespaces + PatternSynonyms -#test explicitnamespaces_patternsynonyms export -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} -module Test (type (++), (++), pattern Foo) where - -#test explicitnamespaces_patternsynonyms import -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} -import Test ( type (++) - , (++) - , pattern (:.) - , pattern Foo - ) - -############################################################################### -## PatternSynonyms -#test bidirectional pattern -{-# LANGUAGE PatternSynonyms #-} -pattern J x = Just x - -#test unidirection pattern -{-# LANGUAGE PatternSynonyms #-} -pattern F x <- (x, _) - -#test explicitly bidirectional pattern -{-# LANGUAGE PatternSynonyms #-} -pattern HeadC x <- x : xs where - HeadC x = [x] - -#test Multiple arguments -{-# LANGUAGE PatternSynonyms #-} -pattern Head2 x y <- x : y : xs where - Head2 x y = [x, y] - -#test Infix argument -{-# LANGUAGE PatternSynonyms #-} -pattern x :> y = [x, y] - -#test Record argument -{-# LANGUAGE PatternSynonyms #-} -pattern MyData { a, b, c } = [a, b, c] - -#test long pattern match -{-# LANGUAGE PatternSynonyms #-} -pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = - [myLongLeftVariableName, myLongRightVariableName] - -#test long explicitly bidirectional match -{-# LANGUAGE PatternSynonyms #-} -pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- - [myLongLeftVariableName, myLongRightVariableName] where - MyInfixPatternMatcher x y = [x, x, y] - -#test Pattern synonym types -{-# LANGUAGE PatternSynonyms #-} -pattern J :: a -> Maybe a -pattern J x = Just x - -#test pattern synonym bidirectional multiple cases -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed x <- (asSigned -> x) where - Signed (Neg x) = -x - Signed Zero = 0 - Signed (Pos x) = x - -#test pattern synonym bidirectional multiple cases long -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- - (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where - Signed (Neg x) = -x - Signed Zero = 0 - Signed (Pos x) = x - -#test pattern synonym bidirectional multiple cases with comments -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed x <- (asSigned -> x) where - Signed (Neg x) = -x -- negative comment - Signed Zero = 0 -- zero comment - Signed (Pos x) = x -- positive comment - -#test Pattern synonym types multiple names -#min-ghc 8.2 -{-# LANGUAGE PatternSynonyms #-} -pattern J, K :: a -> Maybe a - -#test Pattern synonym type sig wrapped -{-# LANGUAGE PatternSynonyms #-} -pattern LongMatcher - :: longlongtypevar - -> longlongtypevar - -> longlongtypevar - -> Maybe [longlongtypevar] -pattern LongMatcher x y z = Just [x, y, z] - - -############################################################################### -## UnboxedTuples + MagicHash -#test unboxed-tuple and vanilla names -{-# LANGUAGE UnboxedTuples #-} -spanKey :: (# Int, Int #) -> (# Int, Int #) -spanKey = case foo of - (# bar, baz #) -> (# baz, bar #) - -#test unboxed-tuple and hashed name -{-# LANGUAGE MagicHash, UnboxedTuples #-} -spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) -spanKey = case foo of - (# bar#, baz# #) -> (# baz# +# bar#, bar# #) - - -############################################################################### -## QuasiQuotes -#test quasi-quotes simple 1 -{-# LANGUAGE QuasiQuotes #-} -func = [blub| - asd - qwe - |] - -#test quasi-quotes simple 2 -{-# LANGUAGE QuasiQuotes #-} -func = [blub| - asd - qwe|] - -#test quasi-quotes ignoring layouting -{-# LANGUAGE QuasiQuotes #-} -func = do - let body = [json| - hello - |] - pure True - -#test quasi-quotes ignoring layouting, strict mode --- brittany { lconfig_allowHangingQuasiQuotes: False } -{-# LANGUAGE QuasiQuotes #-} -func = do - let - body = - [json| - hello - |] - pure True - -############################################################################### -## OverloadedLabels -#test bare label -{-# LANGUAGE OverloadedLabels #-} -foo = #bar - -#test applied and composed label -{-# LANGUAGE OverloadedLabels #-} -foo = #bar . #baz $ fmap #foo xs - -############################################################################### -## ImplicitParams - -#test IP usage -{-# LANGUAGE ImplicitParams #-} -foo = ?bar - -#test IP binding -{-# LANGUAGE ImplicitParams #-} -foo = let ?bar = Foo in value - -#test IP type signature -{-# LANGUAGE ImplicitParams #-} -foo :: (?bar::Bool) => () -foo = () diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt deleted file mode 100644 --- a/src-literatetests/15-regressions.blt +++ /dev/null @@ -1,878 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group regression -############################################################################### -############################################################################### -############################################################################### - -#test newlines-comment -func = do - abc <- foo - ---abc -return () - -#test parenthesis-around-unit -func = (()) - -#test let-defs indentation -func = do - let foo True = True - foo _ = False - return () - -#test record update indentation 1 -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -#test record update indentation 2 -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state - , _lstate_foo = _lstate_foo state - } - -#test record update indentation 3 -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 1 -func = Foo { _lstate_indent = _lstate_indent state } - -#test record construction 2 -func = Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_fooo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 3 -func = do - Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test post-indent comment -func = do --- abc - -- def - return () - -#test post-unindent comment -func = do - do - return () - -- abc - -- def - return () - -#test CPP empty comment case -#pending CPP parsing needs fixing for roundTripEqual -{-# 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. -#test comment inline placement (temporary) -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 - -#test some indentation thingy -func = - ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj - $ abc - $ def - $ ghi - $ jkl - ) - -#test parenthesized operator -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where reassoc (v, e, w) = (v, (e, w)) - -#test record pattern matching stuff -downloadRepoPackage = case repo of - RepoLocal {..} -> return () - RepoLocal { abc } -> return () - RepoLocal{} -> return () - -#test do let comment indentation level problem -func = do - let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' - -- default local dir target if there's no given target - utargets'' = "foo" - return () - -#test list comprehension comment placement -func = - [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_ : _)) <- nosuchFooThing - , gast <- award - ] - -#test if-then-else comment placement -func = if x - then if y -- y is important - then foo - else bar - else Nothing - -#test qualified infix pattern -#pending "TODO" -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR - -#test type signature multiline forcing issue -layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () - -#test multiwayif proper indentation -{-# LANGUAGE MultiWayIf #-} -readMergePersConfig path shouldCreate conf = do - exists <- liftIO $ System.Directory.doesFileExist path - if - | exists -> do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn e - mzero - Right x -> return x - return $ fileConf Semigroup.<> conf - | shouldCreate -> do - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) - staticDefaultConfig - return $ conf - | otherwise -> do - return conf - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _ ) -> InstallOk - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _ ) -> InstallOk - -#test partially overflowing alignment issue" -showPackageDetailedInfo pkginfo = - renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) - $ char '*' - $+$ something - [ entry "Synopsis" synopsis hideIfNull reflowParagraphs - , entry "Versions available" - sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry - "Versions installed" - installedVersions - (altText - null - (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") - ) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description hideIfNull reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) - then empty - else text "Modules:" - $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ] - -#test issue 7a -isValidPosition position | validX && validY = Just position - | otherwise = Nothing - -#test issue-6-pattern-linebreak-validity -## this is ugly, but at least syntactically valid. -foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do - (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String - -> IO Bool ) <- - ReflexHost.newExternalEvent - liftIO . forkIO . forever $ getLine >>= inputFire - ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent - -#test issue 16 -foldrDesc f z = unSwitchQueue $ \q -> - switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) - -#test issue 18 -autocheckCases = - [ ("Never Deadlocks" , representative deadlocksNever) - , ("No Exceptions" , representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative - ] - -#test issue 18b -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions" , representative exceptionsNever) - , ( "Consistent Result" - , alwaysSame -- already representative - ) - ] - -#test issue 18c -func = - [ (abc, (1111, 1111)) - , (def, (2, 2)) - , foo -- comment - ] - -#test issue 26 -foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - where g a b = b + b * a - -#test issue 26b -foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo - -#test aggressive alignment 1 -func = do - abc <- expr - abcccccccccccccccccc <- expr - abcccccccccccccccccccccccccccccccccccccccccc <- expr - abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr - -#test example alignment 1 -func (MyLongFoo abc def) = 1 -func (Bar a d ) = 2 -func _ = 3 - -#test listcomprehension-case-of -parserCompactLocation = - [ try - $ [ ParseRelAbs (Text.Read.read digits) _ _ - | digits <- many1 digit - , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe - [ case divPart of - Nothing -> Left $ Text.Read.read digits - Just ddigits -> - Right $ Text.Read.read digits % Text.Read.read ddigits - | digits <- many1 digit - , divPart <- optionMaybe (string "/" *> many1 digit) - ] - ] - ] - -#test opapp-specialcasing-1 -func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-2 -func = - fooooooooooooooooooooooooooooooooo - + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-3 -func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo - [ foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - ] - -#test opapp-indenting -parserPrim = - [ r - | r <- - [ SGPPrimFloat $ bool id (0 -) minus $ readGnok "parserPrim" - (d1 ++ d2 ++ d3 ++ d4) - | d2 <- string "." - , d3 <- many1 (oneOf "0123456789") - , _ <- string "f" - ] - <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "f" - ] - <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "i" - ] - ] - -#test another-parspacing-testcase - -samples = (SV.unpackaaaaadat) <&> \f -> - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -#test recordupd-singleline-bug - -runBrittany tabSize text = do - let config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text - -#test recordupd-singleline-bug-left - --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -runBrittany tabSize text = do - let - config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text - -#test issue 37 - -foo = - ( a - , -- comment1 - b - -- comment2 - , c - ) - -#test issue 38 - -{-# LANGUAGE TypeApplications #-} -foo = bar @Baz - -#test comment-before-BDCols -{-# LANGUAGE TypeApplications #-} -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do - docAlt - $ -- one-line solution - [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - | not hasComments - , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> [] - ] - ++ -- one-line solution + where in next line(s) - [ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] - ] - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - -#test comment-testcase-17 -{-# LANGUAGE MultiWayIf #-} -func = do - let foo = if - | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO - -> max - (defLen - 0.2) -- TODO - (defLen * 0.8) - | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO - return True - -#test issue 49 - -foo n = case n of - 1 -> True - -1 -> False - -bar n = case n of - (-2, -2) -> (-2, -2) - -#test issue 48 b - -{-# LANGUAGE TypeApplications #-} -foo = - let a = b @1 - cccc = () - in foo - -#test issue 52 a - -{-# LANGUAGE RecordWildCards #-} -v = A { a = 1, .. } where b = 2 - -#test issue 52 b - -{-# LANGUAGE RecordWildCards #-} -v = A { .. } where b = 2 - -#test issue 52 c - -{-# LANGUAGE RecordWildCards #-} -v = A { a = 1, b = 2, c = 3 } - -#test issue 63 a -#pending fix does not work on 8.0.2 -test :: Proxy 'Int - -#test issue 63 b -#pending fix does not work on 8.0.2 -test :: Proxy '[ 'True] - -#test issue 63 c -#pending fix does not work on 8.0.2 -test :: Proxy '[Bool] - -#test issue 64 -{-# LANGUAGE RankNTypes, KindSignatures #-} -func - :: forall m str - . (Str str, Monad m) - => Int - -> Proxy (str :: [*]) - -> m (Tagged str String) - -#test issue 65 -widgetsDyn = - [ [ vBox - [ padTop Max outputLinesWidget - , padRight Max wid1 <+> flowWidget -- alignment here is strange/buggy - , padBottom (Pad 5) help - ] - ] - | wid1 <- promptDyn - , (flowWidget, _) <- flowResultD - , outputLinesWidget <- outputLinesWidgetD - , help <- suggestionHelpBox - , parser <- cmdParserD - ] - -#test issue 67 -fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b -fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) - - -#test parallellistcomp-workaround -cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] - -#test issue 70 -{-# LANGUAGE TemplateHaskell #-} -deriveFromJSON (unPrefix "assignPost") ''AssignmentPost - -#test issue 110 -main = -- a - let --b - x = 1 -- x - y = 2 -- y - in do - print x - print y - -#test issue 111 -alternatives :: Parser (Maybe Text) -alternatives = - alternativeOne -- first try this one - <|> alterantiveTwo -- then this one - <|> alternativeThree -- then this one - where - alternativeOne = purer "one" - alternativeTwo = purer "two" - alterantiveThree = purer "three" - -#test issue 116 -{-# LANGUAGE BangPatterns #-} -func = do - let !forced = some - pure () - -#test let-in-hanging -spanKey p q = case minViewWithKey q of - Just ((k, _), q') | p k -> - let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') - _ -> ([], q) - -#test issue 125 -a :: () ':- () - -#test issue 128 -func = do - createDirectoryIfMissing True path - openFile fileName AppendMode - -#test hspar-comments - -alternatives :: Parser (Maybe Text) -alternatives = -- a - ( -- b - alternativeOne -- c - <|> alterantiveTwo -- d - <|> alternativeThree -- e - ) -- f - -#test issue 133 -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall a - . () - => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -func - :: () - => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -#test alignment-potential-overflow -go l [] = Right l -go l ((IRType, _a) : eqr) = go l eqr -go l ((_, IRType) : eqr) = go l eqr -go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 -go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 - -#test issue 89 - type-family-instance -type instance XPure StageParse = () -type Pair a = (a, a) - -#test issue 144 --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = - let - eyuAfrarIso' - :: (RveoexdxunuAafalm -> Axlau (Axlau (a, OinejrdCplle))) - -> Gbodoy - -> Axlau (Axlau OinejrdCplle, Gbodoy) - eyuAfrarIso' = ulcPaaekBst cnehokzozwbVaguvu - amkgoxEhalazJjxunecCuIfaw - :: Axlau (Axlau OinejrdCplle, Gbodoy) -> Axlau RqlnrluYqednbCiggxi - amkgoxEhalazJjxunecCuIfaw uKqviuBisjtn = do - (sEmo, quc) <- uKqviuBisjtn - pure (xoheccewfWoeyiagOkfodiq sEmo quc) - xoheccewfWoeyiagOkfodiq - :: Axlau OinejrdCplle -> Gbodoy -> RqlnrluYqednbCiggxi - xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of - Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo - in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) - -#test issue 159 -spec = do - it "creates a snapshot at the given level" . withGraph runDB $ do - lift $ do - studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x - elaSnapshotReadingLevel snapshot `shouldBe` 12 - -#test non-bottom-specialcase-altsearch -jaicyhHumzo btrKpeyiFej mava = do - m :: VtohxeRgpmgsu <- qloxIfiq mava - case m of - ZumnaoFujayerIswadabo kkecm chlixxag -> do - imomue <- ozisduRaqiseSBAob btrKpeyiFej $ \s -> - case MizA.pigevo kkecm (_tc_gulawulu s) of - Ebocaba -> - ( s { _tc_gulawulu = MizA.jxariu kkecm rwuRqxzhjo (_tc_gulawulu s) } - , Gtzvonm - ) - Xcde{} -> (s, Pioemav) - pure imomue - -#test issue 214 --- brittany { lconfig_indentPolicy: IndentPolicyMultiple } -foo = bar - arg1 -- this is the first argument - arg2 -- this is the second argument - arg3 -- this is the third argument, now I'll skip one comment - arg4 - arg5 -- this is the fifth argument - arg6 -- this is the sixth argument - -#test issue 234 - -True `nand` True = False -nand _ _ = True - -nor False False = True -_ `nor` _ = False - -#test issue 256 prefix operator match - -f ((:) a as) = undefined - -#test issue 228 lambda plus lazy or bang pattern - -{-# LANGUAGE BangPatterns #-} -a = \x -> x -b = \ ~x -> x -c = \ !x -> x -d = \(~x) -> x - -#test type signature with forall and constraint -{-# LANGUAGE RankNTypes #-} -func :: forall b . Show b => b -> String - -#test issue 267 - -{-# LANGUAGE TypeFamilies #-} -f :: ((~) a b) => a -> b -f = id - -#test large record update --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -vakjkeSulxudbFokvir = Duotpo - { _ekku_gcrpbze = xgonae (1 :: Int) - , _oola_louwu = FoqsiYcuidx - { _xxagu_umea_iaztoj = xgonae False - , _tuktg_tizo_kfikacygsqf = xgonae False - , _ahzbo_xpow_otq_nzeyufq = xgonae False - , _uagpi_lzps_luy_xcjn = xgonae False - , _dxono_qjef_aqtafq_bes = xgonae False - , _yzuaf_nviy_vuhwxe_ihnbo_uhw = xgonae False - , _iwcit_fzjs_yerakt_dicox_mtryitko = xgonae False - , _ehjim_ucfe_dewarp_newrt_gso = xgonae False - , _ogtxb_ivoj_amqgai_rttui_xuwhetb = xgonae False - , _bhycb_iexz_megaug_qunoa_ohaked = xgonae False - , _nnmbe_uqgt_ewsuga_vaiis = xgonae False - , _otzil_ucvugaiyj_aosoiatunx_asir = xgonae False - } - , _iwsc_lalojz = XqspaiDainqw - { _uajznac_ugah = xgonae (80 :: Int) - , _qayziku_gazibzDejipj = xgonae DewizeCxwgyiKjig - , _auhebll_fiqjxyArfxia = xgonae (2 :: Int) - , _zubfuhq_dupiwnIoophXameeet = xgonae True - , _oavnuqg_opkreyOufuIkifiin = xgonae True - , _ufojfwy_fhuzcePeqwfu = xgonae (50 :: Int) - , _mlosikq_zajdxxSeRoelpf = xgonae (50 :: Int) - , _heemavf_fjgOfoaikh = xgonae (FyoVfvdygaZuzuvbeWarwuq 3) - , _ohxmeoq_ogtbfoPtqezVseu = xgonae (EdjotoLcbapUdiuMmytwoig 0.7) - , _omupuiu_ituamexjuLccwu = xgonae (30 :: Int) - , _xoseksf_atvwwdwaoHanofMyUvujjopoz = xgonae True - , _umuuuat_nuamezwWeqfUqzrnaxwp = xgonae False - , _uuriguz_wixhutbuKecigaFiwosret = xgonae True - , _betohxp_scixaLsvcesErtwItxrnaJmuz = xgonae False - , _lchxgee_olaetGcqzuqxVujenCzexub = xgonae True - , _egeibao_imamkuigqikhZdcbpidokVcixiqew = xgonae False - } - , _nloo_cfmrgZcisiugk = YuwodSavxwnicBekuel - { _oebew_rrtpvthUzlizjAqIwesly = xgonae False - , _blkff_Acxoid = xgonae False - , _datei_YewolAowoqOpunvpgu = xgonae BeekgUzojaPnixxaruJehyPmnnfu - , _ejfrj_eheb_justvh_pumcp_ismya = xgonae False - } - , _kena_uzeddovosoki = NyoRvshullezUpauud - { _mtfuwi_TUVEmoi = xgonae RZXKoytUtogx - , _larqam_adaxPehaylZafeqgpc = xgonae False - } - , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } - , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False - , _qaqb_eykzuyuwi = xgonae False - -- test comment - } - -#test large record wildcard comment - --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -vakjkeSulxudbFokvir = Duotpo - { _ekku_gcrpbze = xgonae (1 :: Int) - , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } - , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False - , _qaqb_eykzuyuwi = xgonae False - -- test comment - , -- N.B. - .. -- x - } - -#test issue 263 - -func = abc + def - -- a - -- b - - -- comment - - where - abc = 13 - def = 1 - -#test AddBaseY/EnsureIndent float in effect - -zItazySunefp twgq nlyo lwojjoBiecao = - let mhIarjyai = - ukwAausnfcn - $ XojlsTOSR.vuwOvuvdAZUOJaa - $ XojlsTOSR.vkesForanLiufjeDI - $ XojlsTOSR.vkesForanLiufjeDI - $ XojlsTOSR.popjAyijoWarueeP - $ XojlsTOSR.jpwuPmafuDqlbkt nlyo - $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng - $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow - $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) - $ etOslnoz lwojjoBiecao - in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) - -#test module initial comment --- test -module MyModule where - -#test issue 231 - -foo = - [ ("xxx", "xx") - , -- - ("xx" , "xx") - -- - , ("xx" , "xxxxx") - , ("xx" , "xx") - ] - -#test issue 231 not - -foo = - [ ("xx", "xx") - , ( "xx" -- - , "xx" - ) - , ("xx", "xxxxx") - , ("xx", "xx") - ] - -#test issue 281 - -module Main - ( DataTypeI - , DataTypeII(DataConstructor) - -- * Haddock heading - , name - ) where - -#test type level list - -xeoeqibIaib - :: ( KqujhIsaus m - , XivuvIpoboi Droqifim m - , IgorvOtowtf m - , RyagaYaqac m - , QouruDU m - ) - => MaptAdfuxgu - -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd - -> QNOZqwuzg - -> Eoattuq - '[ XkatytdWdquraosu -- test comment - , KyezKijim -- another test comment - , DjmioeePuoeg - , NinrxoiOwezc - , QATAlrijacpk - , TrutvotwIwifiqOjdtu - , CoMmuatjwr - , BoZckzqyodseZole - , VagfwoXaeChfqe - ] - m - () - -#test recordupd-overflow-bad-multiline-spacing - -createRedirectedProcess processConfig = do - let redirectedProc = (_processConfig_inner processConfig) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - foo - -#test issue 282 - -instance HasDependencies SomeDataModel where - -- N.B. Here is a bunch of explanatory context about the relationship - -- between these data models or whatever. - type Dependencies SomeDataModel - = (SomeOtherDataModelId, SomeOtherOtherDataModelId) - -#test stupid-do-operator-combination - -func = - do - y - >>= x diff --git a/src-literatetests/16-pending.blt b/src-literatetests/16-pending.blt deleted file mode 100644 --- a/src-literatetests/16-pending.blt +++ /dev/null @@ -1,35 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group pending -############################################################################### -############################################################################### -############################################################################### - - - -## this testcase is not about idempotency, but about _how_ the output differs -## from the input; i cannot really express this yet with the current -## test-suite. -## #test ayaz -## -## myManageHook = -## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] -## <+> composeAll -## [ className =? "Pidgin" --> doFloat -## , className =? "XCalc" --> doFloat -## -- plan9port's acme -## , className =? "acme" --> doFloat -## -- Acme with Vi bindings editor -## , title =? "ED" --> doFloat -## , title =? "wlc-x11" --> doFloat -## , className =? "Skype" --> doFloat -## , className =? "ffplay" --> doFloat -## , className =? "mpv" --> doFloat -## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc. -## -- Firefox works well tiled, but it has dialog windows we want to float. -## , appName =? "Browser" --> doFloat -## ] -## where -## role = stringProperty "WM_WINDOW_ROLE" - diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt deleted file mode 100644 --- a/src-literatetests/30-tests-context-free.blt +++ /dev/null @@ -1,1471 +0,0 @@ - -############################################################################### -############################################################################### -############################################################################### -#group type signatures -############################################################################### -############################################################################### -############################################################################### - -#test simple001 -func :: a -> a - -#test long typeVar -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test keep linebreak mode -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - -#test simple parens 1 -func :: ((a)) - -#test simple parens 2 -func :: (a -> a) -> a - -#test simple parens 3 -func :: a -> (a -> a) - -#test did anyone say parentheses? -func :: (((((((((()))))))))) - --- current output is.. funny. wonder if that can/needs to be improved.. -#test give me more! -#pending -func :: ((((((((((((((((((((((((((((((((((((((((((())))))))))))))))))))))))))))))))))))))))))) - -#test unit -func :: () - - -############################################################################### - -#test paren'd func 1 -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - ) - -#test paren'd func 2 -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) - -#test paren'd func 3 -func - :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) - -> lakjsdlkjasldkj - -#test paren'd func 4 -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> lakjsdlkjasldkj - -#test paren'd func 5 -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) - -############################################################################### - -#test type application 1 -func :: asd -> Either a b - -#test type application 2 -func - :: asd - -> Either - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test type application 3 -func - :: asd - -> Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test type application 4 -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd - -#test type application 5 -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) - -#test type application 6 -func - :: Trither - asd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -#test type application paren 1 -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -#test type application paren 2 -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test type application paren 3 -func - :: ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd - -############################################################################### - -#test list simple -func :: [a -> b] - -#test list func -func - :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ] - -#test list paren -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] - -################################################################## -- ############# - -#test tuple type 1 -func :: (a, b, c) - -#test tuple type 2 -func :: ((a, b, c), (a, b, c), (a, b, c)) - -#test tuple type long -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -#test tuple type nested -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) - -#test tuple type function -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] -############################################################################### -#test type operator stuff -#pending -test050 :: a :+: b -test051 - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -test052 - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -############################################################################### - -#test forall oneliner -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b - -#test forall context multiline -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . Foo - => ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () - -#test forall no-context multiline -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () - -#test language pragma issue -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b - -#test comments 1 -func :: a -> b -- comment - -#test comments 2 -funcA :: a -> b -- comment A -funcB :: a -> b -- comment B - -#test comments all -#pending --- a -func -- b - :: -- c - a -- d - -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j --- k - -############################################################################### - -#test ImplicitParams 1 -{-# LANGUAGE ImplicitParams #-} -func :: (?asd::Int) -> () - -#test ImplicitParams 2 -{-# LANGUAGE ImplicitParams #-} -func - :: ( ?asd - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> () - - -############################################################################### -############################################################################### -############################################################################### -#group type signatures pragmas -############################################################################### -############################################################################### -############################################################################### - -#test inline pragma 1 -func = f - where - {-# INLINE f #-} - f = id - -#test inline pragma 2 -func = ($) - where - {-# INLINE ($) #-} - ($) = id - -#test inline pragma 3 -func = f - where - {-# INLINE CONLIKE [1] f #-} - f = id - -#test inline pragma 4 -#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2. -func = f - where - {-# INLINE [~] f #-} - f = id - - -############################################################################### -############################################################################### -############################################################################### -#group data type declarations -############################################################################### -############################################################################### -############################################################################### - -#test single record -data Foo = Bar - { foo :: Baz - } - -#test record multiple names -data Foo = Bar - { foo, bar :: Baz - } - -#test record multiple types -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - -#test record multiple types and names -data Foo = Bar - { foo, biz :: Baz - , bar :: Bizzz - } - -#test record multiple types deriving -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - deriving Show - -#test record multiple types deriving -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) - - -############################################################################### -############################################################################### -############################################################################### -#group equation.basic -############################################################################### -############################################################################### -############################################################################### -## 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.) - -#test basic 1 -func x = x - -#test infix 1 -x *** y = x - -#test symbol prefix -(***) x y = x - - -############################################################################### -############################################################################### -############################################################################### -#group equation.patterns -############################################################################### -############################################################################### -############################################################################### - -#test wildcard -func _ = x - -#test simple long pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - -#test simple multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - -#test another multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - a - b - = x - -#test simple constructor -func (A a) = a - -#test list constructor -func (x : xr) = x - -#test some other constructor symbol -#pending -func (x :+: xr) = x - - -############################################################################### -############################################################################### -############################################################################### -#group equation.guards -############################################################################### -############################################################################### -############################################################################### -#test simple guard -func | True = x - -#test multiple-clauses-1 -func x - | x = simple expression - | otherwise = 0 - -#test multiple-clauses-2 -func x - | a somewhat longer guard x = "and a somewhat longer expession that does not" - | otherwise = "fit without putting the guards in new lines" - -#test multiple-clauses-3 -func x - | very long guard, another rather long guard that refers to x = nontrivial - expression - foo - bar - alsdkjlasdjlasj - | otherwise = 0 - -#test multiple-clauses-4 -func x - | very long guard, another rather long guard that refers to x - = nontrivialexpression foo bar alsdkjlasdjlasj - | otherwise - = 0 - -#test multiple-clauses-5 -func x - | very loooooooooooooooooooooooooooooong guard - , another rather long guard that refers to x - = nontrivial expression foo bar alsdkjlasdjlasj - | otherwise - = 0 - - -############################################################################### -############################################################################### -############################################################################### -#group expression.basic -############################################################################### -############################################################################### -############################################################################### - -#test var -func = x - -describe "infix op" $ do -#test 1 -func = x + x - -#test long -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test long keep linemode 1 -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - -#test long keep linemode 2 -#pending -func = mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test literals -func = 1 -func = "abc" -func = 1.1e5 -func = 'x' -func = 981409823458910394810928414192837123987123987123 - -#test lambdacase -{-# LANGUAGE LambdaCase #-} -func = \case - FooBar -> x - Baz -> y - -#test lambda -func = \x -> abc - -describe "app" $ do -#test 1 -func = klajsdas klajsdas klajsdas - -#test 2 -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - -#test 3 -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljas - lakjsdlajsdljas - lakjsdlajsdljas - -### -#group expression.basic.sections -### - -#test left -func = (1 +) - -#test right -func = (+ 1) - -#test left inf -## TODO: this could be improved.. -func = (1 `abc`) - -#test right inf -func = (`abc` 1) - -### -#group tuples -### - -#test 1 -func = (abc, def) - -#test 2 -#pending -func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) - -#test let in on single line -foo = - let longIdentifierForShortValue = 1 - in longIdentifierForShortValue + longIdentifierForShortValue - - - -############################################################################### -############################################################################### -############################################################################### -#group expression.do statements -############################################################################### -############################################################################### -############################################################################### - -#test simple -func = do - stmt - stmt - -#test bind -func = do - x <- stmt - stmt x - -#test let -func = do - let x = 13 - stmt x - - -############################################################################### -############################################################################### -############################################################################### -#group expression.lists -############################################################################### -############################################################################### -############################################################################### - -#test monad-comprehension-case-of -func = - foooooo - $ [ case - foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - of - _ -> True - ] - - -############################################################################### -############################################################################### -############################################################################### -#group expression.multiwayif -############################################################################### -############################################################################### -############################################################################### - -#test simple -{-# LANGUAGE MultiWayIf #-} -func = if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - -#test simplenested -{-# LANGUAGE MultiWayIf #-} -func = do - foo - bar $ if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - - -############################################################################### -############################################################################### -############################################################################### -#group stylisticspecialcases -############################################################################### -############################################################################### -############################################################################### - -#test operatorprefixalignment-even-with-multiline-alignbreak -func = - foo - $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - ] - ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] - -############################################################################### -############################################################################### -############################################################################### -#group module -############################################################################### -############################################################################### -############################################################################### - -#test simple -module Main where - -#test no-exports -module Main () where - -#test one-export -module Main (main) where - -#test several-exports -module Main (main, test1, test2) where - -#test many-exports -module Main - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) where - -#test exports-with-comments -module Main - ( main - -- main - , test1 - , test2 - -- Test 3 - , test3 - , test4 - -- Test 5 - , test5 - -- Test 6 - ) where - -#test simple-export-with-things -module Main (Test(..)) where - -#test simple-export-with-module-contents -module Main (module Main) where - -#test export-with-things -module Main (Test(Test, a, b)) where - -#test export-with-empty-thing -module Main (Test()) where - -#test empty-with-comment --- Intentionally left empty - -############################################################################### -############################################################################### -############################################################################### -#group import -############################################################################### -############################################################################### -############################################################################### - -#test simple-import -import Data.List - -#test simple-import-alias -import Data.List as L - -#test simple-qualified-import -import qualified Data.List - -#test simple-qualified-import-alias -import qualified Data.List as L - -#test simple-safe -import safe Data.List as L - -#test simple-source -import {-# SOURCE #-} Data.List () - -#test simple-safe-qualified -import safe qualified Data.List hiding (nub) - -#test simple-safe-qualified-source -import {-# SOURCE #-} safe qualified Data.List - -#test simple-qualified-package -import qualified "base" Data.List - -#test qualifier-effect -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List () -import {-# SOURCE #-} safe qualified Data.List hiding () - -#test instances-only -import qualified Data.List () - -#test one-element -import Data.List (nub) - -#test several-elements -import Data.List (foldl', indexElem, nub) - -#test a-ridiculous-amount-of-elements -import Test - ( Long - , anymore - , fit - , items - , line - , list - , not - , onA - , quite - , single - , that - , will - , with - ) - -#test with-things -import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>))) - -#test hiding -import Test hiding () -import Test as T hiding () - -#test import-hiding-many -import Prelude as X - hiding - ( head - , init - , last - , maximum - , minimum - , pred - , read - , readFile - , succ - , tail - , undefined - ) - -#test long-module-name-simple -import MoreThanSufficientlyLongModuleNameWithSome - (compact, fit, inA, items, layout, not, that, will) -import TestJustAbitToLongModuleNameLikeThisOneIs () -import TestJustShortEnoughModuleNameLikeThisOne () - -#test long-module-name-as -import TestJustAbitToLongModuleNameLikeThisOneI as T -import TestJustShortEnoughModuleNameLikeThisOn as T - -#test long-module-name-hiding -import TestJustAbitToLongModuleNameLikeTh hiding () -import TestJustShortEnoughModuleNameLike hiding () - -#test long-module-name-simple-items -import MoreThanSufficientlyLongModuleNameWithSome - (compact, fit, inA, items, layout, not, that, will) - -#test long-module-name-hiding-items -import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) - -#test import-with-comments --- Test -import Data.List (nub) -- Test -{- Test -} -import qualified Data.List as L (foldl') {- Test -} - -#test import-with-comments-2 - -import Test - ( abc - , def - -- comment - ) - -#test import-with-comments-3 - -import Test - ( abc - -- comment - ) - -#test import-with-comments-4 -import Test - ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) - --- Test -import Test (test) - -#test import-with-comments-5 -import Test - ( -- comment - ) - -#test long-bindings -import Test (longbindingNameThatoverflowsColum) -import Test (Long(List, Of, Things)) - -#test things-with-with-comments -import Test - ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) -import Test - ( Thing - ( Item - -- and Comment - ) - ) -import Test - ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) - -#test prefer-dense-empty-list -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine - () - -#test preamble full-preamble -{-# LANGUAGE BangPatterns #-} - -{- - - Test module - -} -module Test - ( test1 - -- ^ test - , test2 - -- | test - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - ) where - --- Test -import Data.List (nub) -- Test -{- Test -} -import qualified Data.List as L (foldl') {- Test -} - --- Test -import Test (test) - -############################################################################### -############################################################################### -############################################################################### -#group regression -############################################################################### -############################################################################### -############################################################################### - -#test newlines-comment -func = do - abc <- foo - ---abc -return () - -#test parenthesis-around-unit -func = (()) - -#test let-defs indentation -func = do - let - foo True = True - foo _ = False - return () - -#test let-defs no indent -func = do - let - foo True = True - foo _ = False - return () - -#test let-defs no indent -func = do - let - foo = True - b = False - return () - -#test let-defs no indent -func = - let - foo = True - b = False - in return () - -#test record update indentation 1 -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -#test record update indentation 2 -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent state - , _lstate_foo = _lstate_foo state - } - -#test record update indentation 3 -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo kasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 1 -func = Foo { _lstate_indent = _lstate_indent state } - -#test record construction 2 -func = Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 3 -func = do - Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test post-indent comment -func = do --- abc - -- def - return () - -#test post-unindent comment -func = do - do - return () - -- abc - -- def - return () - -#test CPP empty comment case -#pending CPP parsing needs fixing for roundTripEqual -{-# 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. -#test comment inline placement (temporary) -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 - -#test some indentation thingy -func = - (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj - $ abc - $ def - $ ghi - $ jkl - ) - -#test parenthesized operator -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where reassoc (v, e, w) = (v, (e, w)) - -#test record pattern matching stuff -downloadRepoPackage = case repo of - RepoLocal {..} -> return () - RepoLocal { abc } -> return () - RepoLocal{} -> return () - -#test do let comment indentation level problem -func = do - let - (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' - -- default local dir target if there's no given target - utargets'' = "foo" - return () - -#test list comprehension comment placement -func = - [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_ : _)) <- nosuchFooThing - , gast <- award - ] - -#test if-then-else comment placement -func = if x - then if y -- y is important - then foo - else bar - else Nothing - -#test qualified infix pattern -#pending "TODO" -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR - -#test type signature multiline forcing issue -layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () - -#test multiwayif proper indentation -{-# LANGUAGE MultiWayIf #-} -readMergePersConfig path shouldCreate conf = do - exists <- liftIO $ System.Directory.doesFileExist path - if - | exists -> do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn e - mzero - Right x -> return x - return $ fileConf Semigroup.<> conf - | shouldCreate -> do - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) - staticDefaultConfig - return $ conf - | otherwise -> do - return conf - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _) -> InstallOk - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _) -> InstallOk - -#test partially overflowing alignment issue" -showPackageDetailedInfo pkginfo = - renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) - $ char '*' - $+$ something - [ entry "Synopsis" synopsis hideIfNull reflowParagraphs - , entry - "Versions available" - sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry - "Versions installed" - installedVersions - (altText - null - (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") - ) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description hideIfNull reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) - then empty - else text "Modules:" - $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ] - -#test issue 7a -isValidPosition position - | validX && validY = Just position - | otherwise = Nothing - -#test issue-6-pattern-linebreak-validity -## this is ugly, but at least syntactically valid. -foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do - (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String - -> IO Bool) <- - ReflexHost.newExternalEvent - liftIO . forkIO . forever $ getLine >>= inputFire - ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent - -#test issue 15 --- Test.hs -module Test where - -data X = X - -#test issue 16 -foldrDesc f z = unSwitchQueue $ \q -> - switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) - -#test issue 18 -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative - ] - -#test issue 18b -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ( "Consistent Result" - , alwaysSame -- already representative - ) - ] - -#test issue 18c -func = - [ (abc, (1111, 1111)) - , (def, (2, 2)) - , foo -- comment - ] - -#test issue 26 -foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - where g a b = b + b * a - -#test issue 26b -foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo - -#test aggressive alignment 1 -func = do - abc <- expr - abcccccccccccccccccc <- expr - abcccccccccccccccccccccccccccccccccccccccccc <- expr - abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr - -#test example alignment 1 -func (MyLongFoo abc def) = 1 -func (Bar a d) = 2 -func _ = 3 - -#test listcomprehension-case-of -parserCompactLocation = - [ try - $ [ ParseRelAbs (Text.Read.read digits) _ _ - | digits <- many1 digit - , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe - [ case divPart of - Nothing -> Left $ Text.Read.read digits - Just ddigits -> - Right $ Text.Read.read digits % Text.Read.read ddigits - | digits <- many1 digit - , divPart <- optionMaybe (string "/" *> many1 digit) - ] - ] - ] - -#test opapp-specialcasing-1 -func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-2 -func = - fooooooooooooooooooooooooooooooooo - + foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-3 -func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo - [ foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - ] - -#test opapp-indenting -parserPrim = - [ r - | r <- - [ SGPPrimFloat $ bool id (0 -) minus $ readGnok - "parserPrim" - (d1 ++ d2 ++ d3 ++ d4) - | d2 <- string "." - , d3 <- many1 (oneOf "0123456789") - , _ <- string "f" - ] - <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "f" - ] - <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "i" - ] - ] - -#test another-parspacing-testcase - -samples = (SV.unpackaaaaadat) <&> \f -> - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -#test recordupd-singleline-bug - -runBrittany tabSize text = do - let - config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text - -#test issue 38 - -{-# LANGUAGE TypeApplications #-} -foo = bar @Baz - -#test comment-before-BDCols -{-# LANGUAGE TypeApplications #-} -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do - docAlt - $ -- one-line solution - [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - | not hasComments - , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> [] - ] - ++ -- one-line solution + where in next line(s) - [ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] - ] - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - -#test comment-testcase-17 -{-# LANGUAGE MultiWayIf #-} -func = do - let - foo = if - | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO - -> max - (defLen - 0.2) -- TODO - (defLen * 0.8) - | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO - return True - -#test issue 49 - -foo n = case n of - 1 -> True - -1 -> False - -bar n = case n of - (-2, -2) -> (-2, -2) - -#test issue 48 b - -{-# LANGUAGE TypeApplications #-} -foo = - let - a = b @1 - cccc = () - in foo - -#test issue 176 - -record :: Record -record = Record - { rProperties = - [ "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - ] - } - - -############################################################################### -############################################################################### -############################################################################### -#group pending -############################################################################### -############################################################################### -############################################################################### - - - -## this testcase is not about idempotency, but about _how_ the output differs -## from the input; i cannot really express this yet with the current -## test-suite. -## #test ayaz -## -## myManageHook = -## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] -## <+> composeAll -## [ className =? "Pidgin" --> doFloat -## , className =? "XCalc" --> doFloat -## -- plan9port's acme -## , className =? "acme" --> doFloat -## -- Acme with Vi bindings editor -## , title =? "ED" --> doFloat -## , title =? "wlc-x11" --> doFloat -## , className =? "Skype" --> doFloat -## , className =? "ffplay" --> doFloat -## , className =? "mpv" --> doFloat -## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc. -## -- Firefox works well tiled, but it has dialog windows we want to float. -## , appName =? "Browser" --> doFloat -## ] -## where -## role = stringProperty "WM_WINDOW_ROLE" diff --git a/src-literatetests/40-indent-policy-multiple.blt b/src-literatetests/40-indent-policy-multiple.blt deleted file mode 100644 --- a/src-literatetests/40-indent-policy-multiple.blt +++ /dev/null @@ -1,42 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group indent-policy-multiple -############################################################################### -############################################################################### -############################################################################### - -#test long --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test let indAmount=4 --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo - -#test let indAmount=8 --- brittany { lconfig_indentAmount: 8, lconfig_indentPolicy: IndentPolicyMultiple } -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo - -#test nested do-block --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -foo = asdyf8asdf - "ajsdfas" - [ asjdf asyhf $ do - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ] diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs deleted file mode 100644 --- a/src-literatetests/Main.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} - -module Main - ( main - ) -where - - - -#include "prelude.inc" - -import Test.Hspec -import Test.Hspec.Runner ( hspecWith - , defaultConfig - , configConcurrentJobs - ) - -import qualified Text.Parsec as Parsec -import Text.Parsec.Text ( Parser ) - -import Data.Char ( isSpace ) -import Data.List ( groupBy ) - -import Language.Haskell.Brittany.Internal - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config - -import Data.Coerce ( coerce ) - -import qualified Data.Text.IO as Text.IO -import System.FilePath ( () ) - - - -data InputLine - = GroupLine Text - | HeaderLine Text - | GhcVersionGuardLine Text - | PendingLine - | NormalLine Text - | CommentLine - deriving Show - -data TestCase = TestCase - { testName :: Text - , isPending :: Bool - , minGHCVersion :: Maybe Text - , content :: Text - } - -main :: IO () -main = do - files <- System.Directory.listDirectory "src-literatetests/" - let blts = - List.sort - $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt" `isSuffixOf`) files - inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) - let groups = createChunks =<< inputs - inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" - let groupsCtxFree = createChunks inputCtxFree - let parseVersion :: Text -> Maybe [Int] - parseVersion = - mapM (readMaybe . Text.unpack) . Text.splitOn (Text.pack ".") - let ghcVersion = Data.Maybe.fromJust $ parseVersion $ Text.pack VERSION_ghc - let checkVersion = \case - Nothing -> True -- no version constraint - Just s -> case parseVersion s of - Nothing -> error $ "could not parse version " ++ Text.unpack s - Just v -> v <= ghcVersion - hspec $ do - groups `forM_` \(groupname, tests) -> do - describe (Text.unpack groupname) $ do - tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do - (if isPending test then before_ pending else id) - $ it (Text.unpack $ testName test) - $ roundTripEqual defaultTestConfig - $ content test - groupsCtxFree `forM_` \(groupname, tests) -> do - describe ("context free: " ++ Text.unpack groupname) $ do - tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do - (if isPending test then before_ pending else id) - $ it (Text.unpack $ testName test) - $ roundTripEqual contextFreeTestConfig - $ content test - where - -- this function might be implemented in a weirdly complex fashion; the - -- reason being that it was copied from a somewhat more complex variant. - createChunks :: Text -> [(Text, [TestCase])] - createChunks input = --- fmap (\case --- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines) --- HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines) --- l -> error $ "first non-empty line must start with #test footest\n" ++ show l --- ) --- $ fmap (groupBy grouperT) - fmap groupProcessor - $ groupBy grouperG - $ filter (not . lineIsSpace) - $ fmap lineMapper - $ Text.lines input - where - groupProcessor :: [InputLine] -> (Text, [TestCase]) - groupProcessor = \case - GroupLine g : grouprest -> - (,) g - $ fmap testProcessor - $ groupBy grouperT - $ filter (not . lineIsSpace) - $ grouprest - l -> error $ "first non-empty line must be a #group\n" ++ show l - testProcessor :: [InputLine] -> TestCase - testProcessor = \case - HeaderLine n : rest -> - let normalLines = Data.Maybe.mapMaybe extractNormal rest - in TestCase - { testName = n - , isPending = any isPendingLine rest - , minGHCVersion = Data.List.Extra.firstJust extractMinGhc rest - , content = Text.unlines normalLines - } - l -> - error $ "first non-empty line must start with #test footest\n" ++ show l - extractNormal (NormalLine l) = Just l - extractNormal _ = Nothing - extractMinGhc (GhcVersionGuardLine v) = Just v - extractMinGhc _ = Nothing - isPendingLine PendingLine{} = True - isPendingLine _ = False - specialLineParser :: Parser InputLine - specialLineParser = Parsec.choice - [ [ GroupLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#group" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" - , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof - ] - , [ HeaderLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#test" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" - , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof - ] - , [ GhcVersionGuardLine $ Text.pack version - | _ <- Parsec.try $ Parsec.string "#min-ghc" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" - , version <- Parsec.many1 $ Parsec.noneOf "\r\n:" - ] - , [ PendingLine - | _ <- Parsec.try $ Parsec.string "#pending" - , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") - , _ <- Parsec.eof - ] - , [ CommentLine - | _ <- Parsec.many $ Parsec.oneOf " \t" - , _ <- Parsec.optional $ Parsec.string "##" <* many - (Parsec.noneOf "\r\n") - , _ <- Parsec.eof - ] - , [ NormalLine mempty - | _ <- Parsec.try $ Parsec.string "" - , _ <- Parsec.eof - ] - ] - lineMapper :: Text -> InputLine - lineMapper line = case Parsec.runParser specialLineParser () "" line of - Left _e -> NormalLine line - Right l -> l - lineIsSpace :: InputLine -> Bool - lineIsSpace CommentLine = True - lineIsSpace _ = False - grouperG :: InputLine -> InputLine -> Bool - grouperG _ GroupLine{} = False - grouperG _ _ = True - grouperT :: InputLine -> InputLine -> Bool - grouperT _ HeaderLine{} = False - grouperT _ _ = True - - --------------------- --- past this line: copy-pasta from other test (meh..) --------------------- -roundTripEqual :: Config -> Text -> Expectation -roundTripEqual c t = - fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) - `shouldReturn` Right (PPTextWrapper t) - -newtype PPTextWrapper = PPTextWrapper Text - deriving Eq - -instance Show PPTextWrapper where - show (PPTextWrapper t) = "\n" ++ Text.unpack t - --- brittany-next-binding --columns 160 --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } -defaultTestConfig :: Config -defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } - , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } - -contextFreeTestConfig :: Config -contextFreeTestConfig = defaultTestConfig - { _conf_layout = (_conf_layout defaultTestConfig) - { _lconfig_indentPolicy = coerce IndentPolicyLeft - , _lconfig_alignmentLimit = coerce (1 :: Int) - , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } - } diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs deleted file mode 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module AsymptoticPerfTests - ( asymptoticPerfTest - ) -where - - - -#include "prelude.inc" - -import Test.Hspec - -import Language.Haskell.Brittany.Internal - -import TestUtils - - - -asymptoticPerfTest :: Spec -asymptoticPerfTest = do - it "1000 do statements" - $ roundTripEqualWithTimeout 1500000 - $ (Text.pack "func = do\n") - <> Text.replicate 1000 (Text.pack " statement\n") - it "1000 do nestings" - $ roundTripEqualWithTimeout 4000000 - $ (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 "()" - it "1000 AppOps" - $ roundTripEqualWithTimeout 1000000 - $ (Text.pack "func = expr") - <> Text.replicate 200 (Text.pack "\n . expr") --TODO diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs deleted file mode 100644 --- a/src-unittests/TestMain.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Main where - - - -#include "prelude.inc" - -import Test.Hspec - -import Language.Haskell.Brittany.Internal - -import AsymptoticPerfTests - - - -main :: IO () -main = hspec $ tests - -tests :: Spec -tests = do - describe "asymptotic perf roundtrips" $ asymptoticPerfTest diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs deleted file mode 100644 --- a/src-unittests/TestUtils.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module TestUtils where - - - -#include "prelude.inc" - -import Test.Hspec - --- import NeatInterpolation - -import Language.Haskell.Brittany.Internal - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config - -import System.Timeout ( timeout ) - -import Data.Coerce ( coerce ) - - - -roundTripEqual :: Text -> Expectation -roundTripEqual t = - fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) - `shouldReturn` Right (PPTextWrapper t) - -roundTripEqualWithTimeout :: Int -> Text -> Expectation -roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) - where - action = fmap (fmap PPTextWrapper) - (parsePrintModuleTests 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_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) - { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever - } - , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) - , _conf_forward = ForwardOptions {_options_ghc = Identity []} - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany - ( parsePrintModule - , staticDefaultConfig - , forwardOptionsSyntaxExtsEnabled - , userConfigPath - , findLocalConfigPath - , readConfigs - , readConfigsWithUserConfig - , Config - , CConfig(..) - , CDebugConfig(..) - , CLayoutConfig(..) - , CErrorHandlingConfig(..) - , CForwardOptions(..) - , CPreProcessorConfig(..) - , BrittanyError(..) - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config - diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ /dev/null @@ -1,668 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Internal - ( parsePrintModule - , parsePrintModuleTests - , pPrintModule - , pPrintModuleAndCheck - -- re-export from utils: - , parseModule - , parseModuleFromString - , extractCommentConfigs - , getTopLevelDeclNameMap - ) -where - - - -#include "prelude.inc" - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers - -import Data.Data -import Control.Monad.Trans.Except -import Data.HList.HList -import qualified Data.Yaml -import qualified Data.ByteString.Char8 -import Data.CZipWith -import qualified UI.Butcher.Monadic as Butcher - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.LayouterBasics - -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Indent - -import qualified GHC as GHC - hiding ( parseModule ) -import ApiAnnotation ( AnnKeywordId(..) ) -import GHC ( Located - , runGhc - , GenLocated(L) - , moduleNameString - ) -import RdrName ( RdrName(..) ) -import SrcLoc ( SrcSpan ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -import Bag -#else -import HsSyn -#endif -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Data.Char ( isSpace ) - - - -data InlineConfigTarget - = InlineConfigTargetModule - | InlineConfigTargetNextDecl -- really only next in module - | InlineConfigTargetNextBinding -- by name - | InlineConfigTargetBinding String - -extractCommentConfigs - :: ExactPrint.Anns - -> TopLevelDeclNameMap - -> Either (String, String) (CConfig Option, PerItemConfig) -extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do - let - commentLiness = - [ ( k - , [ x - | (ExactPrint.Comment x _ _, _) <- - ( ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ) - ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] - ) - | (k, ann) <- Map.toList anns - ] - let configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - ( ("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) - let - configParser = Butcher.addAlternatives - [ ( "commandline-config" - , \s -> "-" `isPrefixOf` dropWhile (== ' ') s - , cmdlineConfigParser - ) - , ( "yaml-config-document" - , \s -> "{" `isPrefixOf` dropWhile (== ' ') s - , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") - $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) - . either (\_ -> Nothing) Just - . Data.Yaml.decodeEither' - . Data.ByteString.Char8.pack - -- TODO: use some proper utf8 encoder instead? - ) - ] - parser = do -- we will (mis?)use butcher here to parse the inline config - -- line. - let nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) - Butcher.addCmd "-next-declaration" nextDecl - Butcher.addCmd "-Next-Declaration" nextDecl - Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) - Butcher.addCmd "-next-binding" nextBinding - Butcher.addCmd "-Next-Binding" nextBinding - Butcher.addCmd "-NEXT-BINDING" nextBinding - let disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-binding" disableNextBinding - Butcher.addCmd "-Disable-Next-Binding" disableNextBinding - Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-declaration" disableNextDecl - Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl - Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) - Butcher.addCmd "-disable" disableFormatting - Butcher.addCmd "@" $ do - -- Butcher.addCmd "module" $ do - -- conf <- configParser - -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) - Butcher.addNullCmd $ do - bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetModule, conf) - lineConfigss <- configLiness `forM` \(k, ss) -> do - r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c - pure (k, r) - - let perModule = foldl' - (<>) - mempty - [ conf - | (_ , lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf ) <- lineConfigs - ] - let - perBinding = Map.fromListWith - (<>) - [ (n, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs - , n <- case target of - InlineConfigTargetBinding s -> [s] - InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> - [name] - _ -> [] - ] - let - perKey = Map.fromListWith - (<>) - [ (k, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs - , case target of - InlineConfigTargetNextDecl -> True - InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> - True - _ -> False - ] - - pure - $ ( perModule - , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } - ) - - -getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap -getTopLevelDeclNameMap (L _ (HsModule _name _exports _ decls _ _)) = - TopLevelDeclNameMap $ Map.fromList - [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls - , (name : _) <- [getDeclBindingNames decl] - ] - - --- | Exposes the transformation in an pseudo-pure fashion. The signature --- contains `IO` due to the GHC API not exposing a pure parsing function, but --- there should be no observable effects. --- --- Note that this function ignores/resets all config values regarding --- debugging, i.e. it will never use `trace`/write to stderr. --- --- Note that the ghc parsing function used internally currently is wrapped in --- `mask_`, so cannot be killed easily. If you don't control the input, you --- may wish to put some proper upper bound on the input's size as a timeout --- won't do. -parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) -parsePrintModule configWithDebugs inputText = runExceptT $ do - let config = - configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack - let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack - (anns, parsedSource, hasCPP) <- do - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - parseResult <- lift $ parseModuleFromString - ghcOptions - "stdin" - cppCheckFunc - (hackTransform $ Text.unpack inputText) - case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x - (inlineConf, perItemConf) <- - either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf - let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack - if disableFormatting - then do - return inputText - else do - (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource - else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s - pure $ if hackAroundIncludes - then - ( ews - , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn - (TextL.pack "\n") - outRaw - ) - else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - case - moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack - of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - if hasErrors - then throwE $ errsWarns - else pure $ TextL.toStrict outputTextL - - - --- BrittanyErrors can be non-fatal warnings, thus both are returned instead --- of an Either. --- This should be cleaned up once it is clear what kinds of errors really --- can occur. -pPrintModule - :: Config - -> PerItemConfig - -> ExactPrint.Anns - -> GHC.ParsedSource - -> ([BrittanyError], TextL.Text) -pPrintModule conf inlineConf anns parsedModule = - let ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) - -- unless () $ do - -- - -- debugStrings `forM_` \s -> - -- trace s $ return () - --- | Additionally checks that the output compiles again, appending an error --- if it does not. -pPrintModuleAndCheck - :: Config - -> PerItemConfig - -> ExactPrint.Anns - -> GHC.ParsedSource - -> IO ([BrittanyError], TextL.Text) -pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity - let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] - return (errs', output) - - --- used for testing mostly, currently. --- TODO: use parsePrintModule instead and remove this function. -parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) -parsePrintModuleTests conf filename input = do - let inputStr = Text.unpack input - parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr - case parseResult of -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) -#else - Left (_ , s ) -> return $ Left $ "parsing error: " ++ s -#endif - Right (anns, parsedModule) -> runExceptT $ do - (inlineConf, perItemConf) <- - case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x - let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (errs, ltext) <- if omitCheck - then return $ pPrintModule moduleConf perItemConf anns parsedModule - else lift - $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule - if null errs - then pure $ TextL.toStrict $ ltext - else - let - errStrs = errs <&> \case - ErrorInput str -> str - ErrorUnusedComment str -> str - LayoutWarning str -> str - ErrorUnknownNode str _ -> str - ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs - - --- this approach would for if there was a pure GHC.parseDynamicFilePragma. --- Unfortunately that does not exist yet, so we cannot provide a nominally --- pure interface. - --- parsePrintModuleTests :: Text -> Either String Text --- parsePrintModuleTests 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 --- ErrorUnusedComment str -> str --- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs --- else return $ TextL.toStrict $ Text.Builder.toLazyText out - -toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a -toLocal conf anns m = do - (x, write) <- - lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m - MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) - pure x - -ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM () -ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do - post <- ppPreamble lmod - decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl - let declBindingNames = getDeclBindingNames decl - inlineConf <- mAsk - let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk - <&> \annMap -> Map.findWithDefault Map.empty declAnnKey annMap - - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns - - config <- mAsk - - let config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) - - let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack - toLocal config' filteredAnns $ do - bd <- if exactprintOnly - then briDocMToPPM $ briDocByExactNoComment decl - else do - (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl - mTell debugs - mTell errs - if null errs - then pure r - else briDocMToPPM $ briDocByExactNoComment decl - layoutBriDoc bd - - let finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post - post `forM_` \case - (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do - ppmMoveToExactLoc l - mTell $ Text.Builder.fromString cmStr - (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm - | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm - -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) - _ -> return () - -getDeclBindingNames :: LHsDecl GhcPs -> [String] -getDeclBindingNames (L _ decl) = case decl of - SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) - ValD _ (FunBind _ (L _ n) _ _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] - - --- Prints the information associated with the module annotation --- This includes the imports -ppPreamble - :: GenLocated SrcSpan (HsModule GhcPs) - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do - filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap - -- Since ghc-exactprint adds annotations following (implicit) - -- modules to both HsModule and the elements in the module - -- this can cause duplication of comments. So strip - -- attached annotations that come after the module's where - -- from the module node - config <- mAsk - let shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - - let - (filteredAnns', post) = - case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of - Nothing -> (filteredAnns, []) - Just mAnn -> - let - modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.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.annsDP = pre } - filteredAnns'' = - Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in - (filteredAnns'', post') - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns' - - if shouldReformatPreamble - then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc - else - let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule - return post - -_sigHead :: Sig GhcPs -> String -_sigHead = \case - TypeSig _ names _ -> - "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) - _ -> "unknown sig" - -_bindHead :: HsBind GhcPs -> String -_bindHead = \case - FunBind _ fId _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) - PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" - - - -layoutBriDoc :: BriDocNumbered -> PPMLocal () -layoutBriDoc briDoc = do - -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do - -- Note that briDoc is BriDocNumbered, but state type is BriDoc. - -- That's why the alt-transform looks a bit special here. - traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw - $ briDocToDoc - $ unwrapBriDocNumbered - $ briDoc - -- bridoc transformation: remove alts - transformAlts briDoc >>= mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyFloating .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating - -- bridoc transformation: par removal - mGet >>= transformSimplifyPar .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyColumns .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns - -- bridoc transformation: indent - mGet >>= transformSimplifyIndent .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - - anns :: ExactPrint.Anns <- mAsk - - let state = LayoutState { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - - let remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] - remainingComments - `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) - - return $ () diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ /dev/null @@ -1,719 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ConstraintKinds #-} - -module Language.Haskell.Brittany.Internal.Backend - ( layoutBriDocM - ) -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 Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) - -import GHC ( AnnKeywordId (..) ) - -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - - -import qualified Data.Text.Lazy.Builder as Text.Builder - - -import Data.HList.ContainsType - -import Control.Monad.Extra ( whenM ) - -import qualified Control.Monad.Trans.Writer.Strict as WriterS - - - -type ColIndex = Int - -data ColumnSpacing - = ColumnSpacingLeaf Int - | ColumnSpacingRef Int Int - -type ColumnBlock a = [a] -type ColumnBlocks a = Seq [a] -type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) - -- (ratio of hasSpace, maximum, raw) - -data ColInfo - = ColInfoStart -- start value to begin the mapAccumL. - | ColInfoNo BriDoc - | ColInfo ColIndex ColSig [(Int, ColInfo)] - -instance Show ColInfo where - show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list - -data ColBuildState = ColBuildState - { _cbs_map :: ColMap1 - , _cbs_index :: ColIndex - } - -type LayoutConstraints m = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) - -layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () -layoutBriDocM = \case - BDEmpty -> do - return () -- can it be that simple - BDLit t -> do - layoutIndentRestorePostComment - layoutRemoveIndentLevelLinger - layoutWriteAppend t - BDSeq list -> do - list `forM_` layoutBriDocM - -- in this situation, there is nothing to do about cols. - -- i think this one does not happen anymore with the current simplifications. - -- BDCols cSig list | BDPar sameLine lines <- List.last list -> - -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines - BDCols _ list -> do - list `forM_` layoutBriDocM - BDSeparator -> do - layoutAddSepSpace - BDAddBaseY indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ layoutBriDocM bd - BDBaseYPushCur bd -> do - layoutBaseYPushCur - layoutBriDocM bd - BDBaseYPop bd -> do - layoutBriDocM bd - layoutBaseYPop - BDIndentLevelPushCur bd -> do - layoutIndentLevelPushCur - layoutBriDocM bd - BDIndentLevelPop bd -> do - layoutBriDocM bd - layoutIndentLevelPop - BDEnsureIndent indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteEnsureBlock - layoutBriDocM bd - BDPar indent sameLine indented -> do - layoutBriDocM sameLine - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteNewlineBlock - layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt:_) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd - BDExternal annKey subKeys shouldAddComment t -> do - let tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines - anns :: ExactPrint.Anns <- mAsk - when shouldAddComment $ do - layoutWriteAppend - $ Text.pack - $ "{-" - ++ show (annKey, Map.lookup annKey anns) - ++ "-}" - zip [1 ..] tlines `forM_` \(i, l) -> do - layoutWriteAppend $ l - unless (i == tlineCount) layoutWriteNewlineBlock - do - state <- mGet - let filterF k _ = not $ k `Set.member` subKeys - mSet $ state - { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state - } - BDPlain t -> do - layoutWriteAppend t - BDAnnotationPrior annKey bd -> do - state <- mGet - let m = _lstate_comments state - let moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey - mAnn <- do - let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - annKey - m - } - return mAnn - case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction - Just priors -> do - -- layoutResetSepSpace - priors - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (not $ comment == "(" || comment == ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) - -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - moveToExactLocationAction - layoutBriDocM bd - BDAnnotationKW annKey keyword bd -> do - layoutBriDocM bd - mComments <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let mToSpan = case mAnn of - Just anns | keyword == Nothing -> Just anns - Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just - annR - _ -> Nothing - case mToSpan of - Just anns -> do - let (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annsDP = rest }) - annKey - m - } - return $ nonEmpty comments - _ -> return Nothing - case mComments of - Nothing -> pure () - Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (not $ comment == "(" || comment == ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDAnnotationRest annKey bd -> do - layoutBriDocM bd - annMay <- do - state <- mGet - let m = _lstate_comments state - pure $ Map.lookup annKey m - let mComments = nonEmpty =<< extractAllComments <$> annMay - let semiCount = length [ () - | Just ann <- [ annMay ] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- mAsk <&> - _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack - mModify $ \state -> state - { _lstate_comments = Map.adjust - ( \ann -> ann { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = - flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } - ) - annKey - (_lstate_comments state) - } - case mComments of - Nothing -> do - when shouldAddSemicolonNewlines $ do - [1..semiCount] `forM_` \_ -> layoutWriteNewline - Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (not $ comment == "(" || comment == ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do - mDP <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let relevant = [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] - -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] - case relevant of - [] -> pure Nothing - (ExactPrint.Types.DP (y, x):_) -> do - mSet state { _lstate_commentNewlines = 0 } - pure $ Just (y - _lstate_commentNewlines state, x) - case mDP of - Nothing -> pure () - Just (y, x) -> - -- we abuse this, as we probably will print the KW next, which is - -- _not_ a comment.. - layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 - layoutBriDocM bd - BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd - BDDebug s bd -> do - mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" - layoutBriDocM bd - -briDocLineLength :: BriDoc -> Int -briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc - -- the state encodes whether a separator was already - -- appended at the current position. - where - rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds - BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do - x <- StateS.get - return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - -briDocIsMultiLine :: BriDoc -> Bool -briDocIsMultiLine briDoc = rec briDoc - where - rec :: BriDoc -> Bool - rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ _ _ -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal _ _ _ _ -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_ ] -> False - BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - --- In theory --- ========= - --- .. this algorithm works roughly in these steps: --- --- 1. For each line, get the (nested) column info, descending as far as --- BDCols nodes go. The column info is a (rose) tree where the leafs --- are arbitrary (non-BDCols) BriDocs. --- 2. Walk through the lines and compare its column info with that of its --- predecessor. If both are non-leafs and the column "signatures" align --- (they don't align e.g. when they are totally different syntactical --- structures or the number of children differs), mark these parts of --- the two tree structures as connected and recurse to its children --- (i.e. again comparing the children in this line with the children in --- the previous line). --- 3. What we now have is one tree per line, and connections between "same" --- nodes between lines. These connection can span multiple lines. --- We next look at spacing information. This is available at the leafs, --- but in this step we aggregate _over connections_. At the top level, this --- gives us one piece of data: How long would each line be, if we fully --- aligned everything (kept all connections "active"). In contrast to --- just taking the sum of all leafs for each tree, this line length includes --- the spaces used for alignment. --- 4. Treat those lines where alignment would result in overflowing of the --- column limit. This "treatment" is currently configurable, and can e.g. --- mean: --- a) we stop alignment alltogether, --- b) we remove alignment just from the overflowing lines, --- c) we reduce the number of spaces inserted in overflowing lines using --- some technique to make them not overflow, but without reducing the --- space insertion to zero, --- d) don't do anything --- 5. Actually print the lines, walking over each tree and inserting spaces --- according to the info and decisions gathered in the previous steps. --- --- Possible improvements --- ===================== --- --- - If alignment is disabled for specific lines, the aggregated per-connection --- info of those lines is still retained and not recalculated. This can --- result in spaces being inserted to create alignment with a line that --- would overflow and thus gets disabled entirely. --- An better approach would be to repeat step 3 after marking overflowing --- lines as such, and not include the overflowing spacings as references --- for non-overflowing ones. In the simplest case one additional iteration --- would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine --- this and first remove alignment in the deepest parts of the tree for --- overflowing lines, repeating and moving upwards until no lines are --- anymore overflowing. --- Further, it may make sense to break up connections when overflowing would --- occur. --- - It may also make sense to not filter all overflowing lines, but remove --- them one-by-one and in each step recalculate the aggregated connection --- spacing info. Because removing one overflowing line from the calculation --- may very well cause another previously overflowing line to not overflow --- any longer. --- There is also a nasty optimization problem hiding in there (find the --- minimal amount of alignment disabling that results in no overflows) --- but that is overkill. --- --- (with both these improvements there would be quite some repetition between --- steps 3 and 4, but it should be possible to ensure termination. Still, --- performance might become an issue as such an approach is not necessarily --- linear in bridoc size any more.) --- --- In practice --- =========== --- --- .. the current implementation is somewhat sloppy. Steps 1 and 2 --- are executed in one step, step 3 already applies one strategy that disables --- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some --- of the calculations one might expect to occur in step 3. Steps 4 and 5 --- are executed in the same recursion, too. --- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue --- mentioned in the first "possible improvement". -alignColsLines :: LayoutConstraints m => [BriDoc] -> m () -alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do - -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) - curX <- do - state <- mGet - return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe - 0 - (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack - alignBreak <- - mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack - case () of - _ -> do - -- tellDebugMess ("processedMap: " ++ show processedMap) - sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos - <&> processInfo colMax processedMap - where - (colInfos, finalState) = - StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) - -- maxZipper :: [Int] -> [Int] -> [Int] - -- maxZipper [] ys = ys - -- maxZipper xs [] = xs - -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr - colAggregation :: [Int] -> Int - colAggregation [] = 0 -- this probably cannot happen the way we call - -- this function, because _cbs_map only ever - -- contains nonempty Seqs. - colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ] - where alignMax' = max 0 alignMax - - processedMap :: ColMap2 - processedMap = - fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> - let - colss = colSpacingss <&> \spss -> case reverse spss of - [] -> [] - (xN:xR) -> - reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR - where - fLast (ColumnSpacingLeaf len ) = len - fLast (ColumnSpacingRef len _) = len - fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of - Nothing -> 0 - Just (_, maxs, _) -> sum maxs - maxCols = {-Foldable.foldl1 maxZipper-} - fmap colAggregation $ transpose $ Foldable.toList colss - (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols - counter count l = if List.last posXs + List.last l <= colMax - then count + 1 - else count - ratio = fromIntegral (foldl counter (0 :: Int) colss) - / fromIntegral (length colss) - in - (ratio, maxCols, colss) - - mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocs bds = mergeBriDocsW ColInfoStart bds - - mergeBriDocsW - :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd:bdr) = do - info <- mergeInfoBriDoc True lastInfo bd - infor <- mergeBriDocsW - -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) - (if shouldBreakAfter bd then ColInfoStart else info) - bdr - return $ info : infor - - -- even with alignBreak config flag, we don't stop aligning for certain - -- ColSigs - the ones with "False" below. The main reason is that - -- there are uses of BDCols where they provide the alignment of several - -- consecutive full larger code segments, for example ColOpPrefix. - -- Motivating example is - -- > foo - -- > $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -- > , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - -- > ] - -- > ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ] - -- If we break the alignment here, then all three lines for the first - -- list move left by one, which is horrible. We really don't want to - -- break whole-block alignments. - -- For list, listcomp, tuple and tuples the reasoning is much simpler: - -- alignment should not have much effect anyways, so i simply make the - -- choice here that enabling alignment is the safer route for preventing - -- potential glitches, and it should never have a negative effect. - -- For RecUpdate the argument is much less clear - it is mostly a - -- personal preference to not break alignment for those, even if - -- multiline. Really, this should be configurable.. (TODO) - shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = if alignBreak - then briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True - else False - - mergeInfoBriDoc - :: Bool - -> ColInfo - -> BriDoc - -> StateS.StateT ColBuildState Identity ColInfo - mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = - \case - brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs - -> do - let - isLastList = if lastFlag - then (==length subDocs) <$> [1 ..] - else repeat False - infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs - `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs - let trueSpacings = getTrueSpacings (zip curLengths infos) - do -- update map - s <- StateS.get - let m = _cbs_map s - let (Just (_, spaces)) = IntMapS.lookup infoInd m - StateS.put s - { _cbs_map = IntMapS.insert - infoInd - (lastFlag, spaces Seq.|> trueSpacings) - m - } - return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise - -> briDocToColInfo lastFlag brdc - brdc -> return $ ColInfoNo brdc - -briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo -briDocToColInfo lastFlag = \case - BDCols sig list -> withAlloc lastFlag $ \ind -> do - let isLastList = - if lastFlag then (==length list) <$> [1 ..] else repeat False - subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos - let trueSpacings = getTrueSpacings lengthInfos - return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) - bd -> return $ ColInfoNo bd - -getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] -getTrueSpacings lengthInfos = lengthInfos <&> \case - (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _ ) -> ColumnSpacingLeaf len - -withAlloc - :: Bool - -> ( ColIndex - -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) - ) - -> StateS.State ColBuildState ColInfo -withAlloc lastFlag f = do - cbs <- StateS.get - let ind = _cbs_index cbs - StateS.put $ cbs { _cbs_index = ind + 1 } - (space, info) <- f ind - StateS.get >>= \c -> StateS.put - $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } - return info - -processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () -processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ - do - colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do - state <- mGet - -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) - let spaceAdd = case _lstate_addSepSpace state of - Nothing -> 0 - Just i -> i - return $ case _lstate_curYOrAddNewline state of - Left i -> case _lstate_commentCol state of - Nothing -> spaceAdd + i - Just c -> c - Right{} -> spaceAdd - let colMax = min colMaxConf (curX + maxSpace) - -- tellDebugMess $ show curX - let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let maxCols2 = list <&> \e -> case e of - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l - let maxCols = zipWith max maxCols1 maxCols2 - let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols - -- handle the cases that the vertical alignment leads to more than max - -- cols: - -- this is not a full fix, and we must correct individually in addition. - -- because: the (at least) line with the largest element in the last - -- column will always still overflow, because we just updated the column - -- sizes in such a way that it works _if_ we have sizes (*factor) - -- in each column. but in that line, in the last column, we will be - -- forced to occupy the full vertical space, not reduced by any factor. - let fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (*factor) .> truncate - _ -> posXs - let spacings = zipWith (-) - (List.tail fixedPosXs ++ [min maxX colMax]) - fixedPosXs - -- tellDebugMess $ "ind = " ++ show ind - -- tellDebugMess $ "maxCols = " ++ show maxCols - -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs - -- tellDebugMess $ "list = " ++ show list - -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct - case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct - ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct - -processInfoIgnore :: LayoutConstraints m => ColInfo -> m () -processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) - diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ /dev/null @@ -1,615 +0,0 @@ -#define INSERTTRACES 0 - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeApplications #-} -#if !INSERTTRACES -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif - -module Language.Haskell.Brittany.Internal.BackendUtils - ( layoutWriteAppend - , layoutWriteAppendMultiline - , layoutWriteNewlineBlock - , layoutWriteNewline - , layoutWriteEnsureNewlineBlock - , layoutWriteEnsureBlock - , layoutWithAddBaseCol - , layoutWithAddBaseColBlock - , layoutWithAddBaseColN - , layoutWithAddBaseColNBlock - , layoutBaseYPushCur - , layoutBaseYPop - , layoutIndentLevelPushCur - , layoutIndentLevelPop - , layoutWriteEnsureAbsoluteN - , layoutAddSepSpace - , layoutSetCommentCol - , layoutMoveToCommentPos - , layoutIndentRestorePostComment - , moveToExactAnn - , moveToY - , ppmMoveToExactLoc - , layoutWritePriorComments - , layoutWritePostComments - , layoutRemoveIndentLevelLinger - ) -where - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey - , Annotation - , KeywordId - ) - -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.Brittany.Internal.Utils - -import GHC ( Located, GenLocated(L), moduleNameString ) - - - -traceLocal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a) - => a - -> m () -#if INSERTTRACES -traceLocal x = do - mGet >>= tellDebugMessShow @LayoutState - tellDebugMessShow x -#else -traceLocal _ = return () -#endif - - -layoutWriteAppend - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Text - -> m () -layoutWriteAppend t = do - traceLocal ("layoutWriteAppend", t) - state <- mGet - case _lstate_curYOrAddNewline state of - Right i -> do -#if INSERTTRACES - tellDebugMessShow (" inserted newlines: ", i) -#endif - replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" - Left{} -> do -#if INSERTTRACES - tellDebugMessShow (" inserted no newlines") -#endif - return () - let spaces = case _lstate_addSepSpace state of - Just i -> i - Nothing -> 0 -#if INSERTTRACES - tellDebugMessShow (" inserted spaces: ", spaces) -#endif - mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') - mTell $ Text.Builder.fromText $ t - mModify $ \s -> s - { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces - , _lstate_addSepSpace = Nothing - } - -layoutWriteAppendSpaces - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () -layoutWriteAppendSpaces i = do - traceLocal ("layoutWriteAppendSpaces", i) - 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 ts = do - traceLocal ("layoutWriteAppendMultiline", ts) - case ts of - [] -> layoutWriteAppend (Text.pack "") -- 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 - traceLocal ("layoutWriteNewlineBlock") - state <- mGet - mSet $ state { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ 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 isJust $ _lstate_addNewline state --- then i --- else _lstate_indLevelLinger state + i - _lstate_curY state --- } - -layoutSetCommentCol - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutSetCommentCol = do - state <- mGet - let col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state - traceLocal ("layoutSetCommentCol", col) - unless (Data.Maybe.isJust $ _lstate_commentCol state) - $ mSet state { _lstate_commentCol = Just col } - --- This is also used to move to non-comments in a couple of places. Seems --- to be harmless so far.. -layoutMoveToCommentPos - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> Int - -> Int - -> m () -layoutMoveToCommentPos y x commentLines = do - traceLocal ("layoutMoveToCommentPos", y, x, commentLines) - state <- mGet - mSet state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right{} -> Right y - , _lstate_addSepSpace = - Just $ if Data.Maybe.isJust (_lstate_commentCol state) - then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = - Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state - , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 - } - --- | 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 - traceLocal ("layoutWriteNewline") - state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing - } - -_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () -_layoutResetCommentNewlines = do - mModify $ \state -> state { _lstate_commentNewlines = 0 } - -layoutWriteEnsureNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () -layoutWriteEnsureNewlineBlock = do - traceLocal ("layoutWriteEnsureNewlineBlock") - state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing - } - -layoutWriteEnsureAbsoluteN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () -layoutWriteEnsureAbsoluteN n = do - state <- mGet - let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c , _ ) -> n - c - (Nothing, Left i ) -> n - i - (Nothing, Right{}) -> n - traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) - 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. - } - -layoutBaseYPushInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) - => Int - -> m () -layoutBaseYPushInternal i = do - traceLocal ("layoutBaseYPushInternal", i) - mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } - -layoutBaseYPopInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutBaseYPopInternal = do - traceLocal ("layoutBaseYPopInternal") - mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } - -layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) - => Int - -> m () -layoutIndentLevelPushInternal i = do - traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } - -layoutIndentLevelPopInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutIndentLevelPopInternal = do - traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } - -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 .> confUnpack - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - m - layoutBaseYPopInternal - -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 .> confUnpack - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - layoutWriteEnsureBlock - m - layoutBaseYPopInternal - -layoutWithAddBaseColNBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () - -> m () -layoutWithAddBaseColNBlock amount m = do - traceLocal ("layoutWithAddBaseColNBlock", amount) - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - layoutWriteEnsureBlock - m - layoutBaseYPopInternal - -layoutWriteEnsureBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () -layoutWriteEnsureBlock = do - traceLocal ("layoutWriteEnsureBlock") - state <- mGet - let - diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i ) -> lstate_baseY state - i - (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i ) -> max sp (lstate_baseY state - i) - (Just sp, Right{}) -> max sp (lstate_baseY state) - -- when (diff>0) $ layoutWriteNewlineBlock - when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just $ diff } - -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 - layoutBaseYPushInternal $ lstate_baseY state + amount - m - layoutBaseYPopInternal - -layoutBaseYPushCur - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutBaseYPushCur = do - traceLocal ("layoutBaseYPushCur") - state <- mGet - case _lstate_commentCol state of - Nothing -> - case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> layoutBaseYPushInternal (i + j) - (Left i , Nothing) -> layoutBaseYPushInternal i - (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state - Just cCol -> layoutBaseYPushInternal cCol - -layoutBaseYPop - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutBaseYPop = do - traceLocal ("layoutBaseYPop") - layoutBaseYPopInternal - -layoutIndentLevelPushCur - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutIndentLevelPushCur = do - traceLocal ("layoutIndentLevelPushCur") - state <- mGet - let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> i + j - (Left i , Nothing) -> i - (Right{}, Just j ) -> j - (Right{}, Nothing) -> 0 - layoutIndentLevelPushInternal y - -layoutIndentLevelPop - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () -layoutIndentLevelPop = do - traceLocal ("layoutIndentLevelPop") - layoutIndentLevelPopInternal - -- 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 - traceLocal ("moveToExactAnn", annKey) - anns <- mAsk - case Map.lookup annKey anns of - Nothing -> return () - Just ann -> do - -- curY <- mGet <&> _lstate_curY - let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann - -- mModify $ \state -> state { _lstate_addNewline = Just x } - moveToY y - -moveToY :: MonadMultiState LayoutState m => Int -> m () -moveToY y = mModify $ \state -> - let upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then - _lstate_commentCol state - <|> _lstate_addSepSpace state - <|> Just (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } --- 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.DeltaPos - -> m () -ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do - replicateM_ x $ mTell $ Text.Builder.fromString "\n" - replicateM_ y $ mTell $ Text.Builder.fromString " " - --- TODO: update and use, or clean up. Currently dead code. -layoutWritePriorComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Located ast - -> m () -layoutWritePriorComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns - } - return mAnn -#if INSERTTRACES - tellDebugMessShow ("layoutWritePriorComments", ExactPrint.mkAnnKey ast, mAnn) -#endif - case mAnn of - Nothing -> return () - Just priors -> do - when (not $ null priors) $ layoutSetCommentCol - priors `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment - --- TODO: update and use, or clean up. Currently dead code. --- this currently only extracs from the `annsDP` field of Annotations. --- per documentation, this seems sufficient, as the --- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => Located ast -> m () -layoutWritePostComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns - } - return mAnn -#if INSERTTRACES - tellDebugMessShow ("layoutWritePostComments", ExactPrint.mkAnnKey ast, mAnn) -#endif - case mAnn of - Nothing -> return () - Just posts -> do - when (not $ null posts) $ layoutSetCommentCol - posts `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment - -layoutIndentRestorePostComment - :: ( MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - ) - => m () -layoutIndentRestorePostComment = do - state <- mGet - let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state -#if INSERTTRACES - tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) -#endif - mModify $ \s -> s { _lstate_commentCol = Nothing - , _lstate_commentNewlines = 0 - } - case (mCommentCol, eCurYAddNL) of - (Just commentCol, Left{}) -> do - layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) - _ -> return () - --- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, --- MonadMultiWriter Text.Builder.Builder m, --- MonadMultiState LayoutState m --- , MonadMultiWriter (Seq String) m) --- => Located 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) --- => Located ast -> m () --- layoutWritePostCommentsRestore x = do --- layoutWritePostComments x --- layoutIndentRestorePostComment diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ /dev/null @@ -1,309 +0,0 @@ -module Language.Haskell.Brittany.Internal.Config - ( CConfig(..) - , CDebugConfig(..) - , CLayoutConfig(..) - , DebugConfig - , LayoutConfig - , Config - , cmdlineConfigParser - , staticDefaultConfig - , forwardOptionsSyntaxExtsEnabled - , readConfig - , userConfigPath - , findLocalConfigPath - , readConfigs - , readConfigsWithUserConfig - , writeDefaultConfig - , showConfigYaml - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import qualified Data.Yaml -import Data.CZipWith - -import UI.Butcher.Monadic -import Data.Monoid ( (<>) ) - -import qualified System.Console.CmdArgs.Explicit - as CmdArgs - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances -import Language.Haskell.Brittany.Internal.Utils - -import Data.Coerce ( Coercible - , coerce - ) -import qualified Data.List.NonEmpty as NonEmpty - -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } -staticDefaultConfig :: Config -staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False - , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False - } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) - , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline - , _econf_omit_output_valid_check = coerce False - } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort - , _ppconf_hackAroundIncludes = coerce False - } - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } - -forwardOptionsSyntaxExtsEnabled :: ForwardOptions -forwardOptionsSyntaxExtsEnabled = ForwardOptions - { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] - } - --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } -cmdlineConfigParser :: CmdParser Identity out (CConfig Option) -cmdlineConfigParser = do - -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged 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") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") - - return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar - , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty - } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty - , _lconfig_experimentalSemicolonNewlines = mempty - -- , _lconfig_allowSinglelineRecord = mempty - } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty - , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck - } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } - , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate - } - where - falseToNothing = Option . Bool.bool Nothing (Just True) - wrapLast :: Option a -> Option (Semigroup.Last a) - wrapLast = fmap Semigroup.Last - optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a) - optionConcat = mconcat . fmap (pure . pure) - --- 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 --- } - - --- | Reads a config from a file. If the file does not exist, returns --- Nothing. If the file exists and parsing fails, prints to stderr and --- aborts the MaybeT. Otherwise succeed via Just. --- If the second parameter is True and the file does not exist, writes the --- staticDefaultConfig to the file. -readConfig - :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Option)) -readConfig path = do - -- TODO: probably should catch IOErrors and then omit the existence check. - 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 - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) - mzero - Right x -> return x - return $ Just fileConf - else return $ Nothing - --- | Looks for a user-global config file and return its path. --- If there is no global config in a system, one will be created. -userConfigPath :: IO System.IO.FilePath -userConfigPath = do - userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" - let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith Directory.doesFileExist - searchDirs - "config.yaml" - maybe (writeUserConfig userBritPathXdg) pure globalConfig - where - writeUserConfig dir = do - let createConfPath = dir FilePath. "config.yaml" - liftIO $ Directory.createDirectoryIfMissing True dir - writeDefaultConfig $ createConfPath - pure createConfPath - --- | Searches for a local (per-project) brittany config starting from a given directory -findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) -findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir - -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] - let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) - Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" - --- | Reads specified configs. -readConfigs - :: CConfig Option -- ^ Explicit options, take highest priority - -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first - -> MaybeT IO Config -readConfigs cmdlineConfig configPaths = do - configs <- readConfig `mapM` configPaths - let merged = Semigroup.sconcat - $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) - return $ cZipWith fromOptionIdentity staticDefaultConfig merged - --- | Reads provided configs --- but also applies the user default configuration (with lowest priority) -readConfigsWithUserConfig - :: CConfig Option -- ^ Explicit options, take highest priority - -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first - -> MaybeT IO Config -readConfigsWithUserConfig cmdlineConfig configPaths = do - defaultPath <- liftIO $ userConfigPath - readConfigs cmdlineConfig (configPaths ++ [defaultPath]) - -writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () -writeDefaultConfig path = - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) - staticDefaultConfig - -showConfigYaml :: Config -> String -showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap - (\(Identity x) -> Just x) - diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ /dev/null @@ -1,355 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Language.Haskell.Brittany.Internal.Config.Types - ( module Language.Haskell.Brittany.Internal.Config.Types - , cMap - ) -where - - - -#include "prelude.inc" - -import Data.Yaml -import qualified Data.Aeson.Types as Aeson -import GHC.Generics - -import Data.Data ( Data ) - -import Data.Coerce ( Coercible, coerce ) - -import Data.Semigroup.Generic -import Data.Semigroup ( Last, Option ) - -import Data.CZipWith - - - -confUnpack :: Coercible a b => Identity a -> b -confUnpack (Identity x) = coerce x - -data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - } - deriving (Generic) - -data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. - , _lconfig_indentPolicy :: f (Last IndentPolicy) - , _lconfig_indentAmount :: f (Last Int) - , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," - -- when creating zero-indentation - -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) - -- ^ for import statement layouting, column at which to align the - -- elements to be imported from a module. - -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) - -- ^ for import statement layouting, column at which put the module's - -- "as" name (which also affects the positioning of the "as" keyword). - -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) - , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) - -- roughly speaking, this sets an upper bound to the number of spaces - -- inserted to create horizontal alignment. - -- More specifically, if 'xs' are the widths of the columns in some - -- alignment-block, then the block will be aligned with the width - -- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ]. - , _lconfig_alignmentBreakOnMultiline :: f (Last Bool) - -- stops alignment between items that are not layouted as a single line. - -- e.g. for single-line alignment, things remain unchanged: - -- do - -- short <- stuff - -- loooooooong <- stuff - -- but not in cases such as: - -- do - -- short <- some more stuff - -- that requires two lines - -- loooooooong <- stuff - , _lconfig_hangingTypeSignature :: f (Last Bool) - -- Do not put "::" in a new line, and use hanging indentation for the - -- signature, i.e.: - -- func :: SomeLongStuff - -- -> SomeLongStuff - -- instead of the usual - -- func - -- :: SomeLongStuff - -- -> SomeLongStuff - -- As usual for hanging indentation, the result will be - -- context-sensitive (in the function name). - , _lconfig_reformatModulePreamble :: f (Last Bool) - -- whether the module preamble/header (module keyword, name, export list, - -- import statements) are reformatted. If false, only the elements of the - -- module (everything past the "where") are reformatted. - , _lconfig_allowSingleLineExportList :: f (Last Bool) - -- if true, and it fits in a single line, and there are no comments in the - -- export list, the following layout will be used: - -- > module MyModule (abc, def) where - -- > [stuff] - -- otherwise, the multi-line version is used: - -- > module MyModule - -- > ( abc - -- > , def - -- > ) - -- > where - , _lconfig_allowHangingQuasiQuotes :: f (Last Bool) - -- if false, the layouter sees any splices as infinitely big and places - -- them accordingly (in newlines, most likely); This also influences - -- parent nodes. - -- if true, the layouter is free to start a quasi-quotation at the end - -- of a line. - -- - -- false: - -- > let - -- > body = - -- > [json| - -- > hello - -- > |] - -- - -- true: - -- > let body = [json| - -- > hello - -- > |] - , _lconfig_experimentalSemicolonNewlines :: f (Last Bool) - -- enables an experimental feature to turn semicolons in brace notation - -- into newlines when using layout: - -- - -- > do { a ;; b } - -- - -- turns into - -- > do - -- > a - -- > - -- > b - -- - -- The implementation for this is a bit hacky and not tested; it might - -- break output syntax or not work properly for every kind of brace. So - -- far I have considered `do` and `case-of`. - -- , _lconfig_allowSinglelineRecord :: f (Last Bool) - -- -- if true, layouts record data decls as a single line when possible, e.g. - -- -- > MyPoint { x :: Double, y :: Double } - -- -- if false, always use the multi-line layout - -- -- > MyPoint - -- -- > { x :: Double - -- -- > , y :: Double - -- -- > } - } - deriving (Generic) - -data CForwardOptions f = ForwardOptions - { _options_ghc :: f [String] - } - deriving (Generic) - -data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) - -- ^ Determines when to fall back on the exactprint'ed output when - -- syntactical constructs are encountered which are not yet handled by - -- brittany. - -- Note that the "risky" setting is risky because even with the check of - -- the syntactic validity of the brittany output, at least in theory there - -- may be cases where the output is syntactically/semantically valid but - -- has different semantics than the code pre-transformation. - , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) - } - deriving (Generic) - -data CPreProcessorConfig f = PreProcessorConfig - { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) - , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) - } - deriving (Generic) - -data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f - , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f - , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - -- ^ this field is somewhat of a duplicate of the one in DebugConfig. - -- It is used for per-declaration disabling by the inline config - -- implementation. Could have re-used the existing field, but felt risky - -- to use a "debug" labeled field for non-debug functionality. - , _conf_disable_formatting :: f (Semigroup.Last Bool) - -- ^ Used for inline config that disables brittany entirely for this - -- module. Useful for wildcard application - -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something - -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) - - } - deriving (Generic) - -type DebugConfig = CDebugConfig Identity -type LayoutConfig = CLayoutConfig Identity -type ForwardOptions = CForwardOptions Identity -type ErrorHandlingConfig = CErrorHandlingConfig Identity -type Config = CConfig Identity - --- i wonder if any Show1 stuff could be leveraged. -deriving instance Show (CDebugConfig Identity) -deriving instance Show (CLayoutConfig Identity) -deriving instance Show (CErrorHandlingConfig Identity) -deriving instance Show (CForwardOptions Identity) -deriving instance Show (CPreProcessorConfig Identity) -deriving instance Show (CConfig Identity) - -deriving instance Show (CDebugConfig Option) -deriving instance Show (CLayoutConfig Option) -deriving instance Show (CErrorHandlingConfig Option) -deriving instance Show (CForwardOptions Option) -deriving instance Show (CPreProcessorConfig Option) -deriving instance Show (CConfig Option) - -deriving instance Data (CDebugConfig Identity) -deriving instance Data (CLayoutConfig Identity) -deriving instance Data (CErrorHandlingConfig Identity) -deriving instance Data (CForwardOptions Identity) -deriving instance Data (CPreProcessorConfig Identity) -deriving instance Data (CConfig Identity) - -deriving instance Data (CDebugConfig Option) -deriving instance Data (CLayoutConfig Option) -deriving instance Data (CErrorHandlingConfig Option) -deriving instance Data (CForwardOptions Option) -deriving instance Data (CPreProcessorConfig Option) -deriving instance Data (CConfig Option) - -instance Semigroup.Semigroup (CDebugConfig Option) where - (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Option) where - (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Option) where - (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Option) where - (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Option) where - (<>) = gmappend -instance Semigroup.Semigroup (CConfig Option) where - (<>) = gmappend - -instance Semigroup.Semigroup (CDebugConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CConfig Identity) where - (<>) = gmappend - -instance Monoid (CDebugConfig Option) where - mempty = gmempty - mappend = gmappend -instance Monoid (CLayoutConfig Option) where - mempty = gmempty - mappend = gmappend -instance Monoid (CErrorHandlingConfig Option) where - mempty = gmempty - mappend = gmappend -instance Monoid (CForwardOptions Option) where - mempty = gmempty - mappend = gmappend -instance Monoid (CPreProcessorConfig Option) where - mempty = gmempty - mappend = gmappend -instance Monoid (CConfig Option) where - mempty = gmempty - mappend = gmappend - - -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 (Eq, 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) - -data ColumnAlignMode - = ColumnAlignModeDisabled - -- ^ Make no column alignments whatsoever - | ColumnAlignModeUnanimously - -- ^ Make column alignments only if it does not cause overflow for any of - -- the affected lines. - | ColumnAlignModeMajority Float - -- ^ If at least (ratio::Float) of the aligned elements have sufficient - -- space for the alignment, act like ColumnAlignModeAnimously; otherwise - -- act like ColumnAlignModeDisabled. - | ColumnAlignModeAnimouslyScale Int - -- ^ Scale back columns to some degree if their sum leads to overflow. - -- This is done in a linear fashion. - -- The Int specifies additional columns to be added to column maximum for - -- scaling calculation purposes. - | ColumnAlignModeAnimously - -- ^ Decide on a case-by-case basis if alignment would cause overflow. - -- If it does, cancel all alignments for this (nested) column description. - -- ColumnAlignModeAnimouslySome -- potentially to implement - | ColumnAlignModeAlways - -- ^ Always respect column alignments, even if it makes stuff overflow. - deriving (Show, Generic, Data) - -data CPPMode = CPPModeAbort -- abort program on seeing -XCPP - | CPPModeWarn -- warn about CPP and non-roundtripping in its - -- presence. - | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is - -- file.) - deriving (Show, Generic, Data) - -data ExactPrintFallbackMode - = ExactPrintFallbackModeNever -- never fall back on exactprinting - | ExactPrintFallbackModeInline -- fall back only if there are no newlines in - -- the exactprint'ed output. - | ExactPrintFallbackModeRisky -- fall back even in the presence of newlines. - -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF - -- A PROGRAM BY TRANSFORMING IT. - deriving (Show, Generic, Data) - -instance CFunctor CDebugConfig -instance CFunctor CLayoutConfig -instance CFunctor CErrorHandlingConfig -instance CFunctor CForwardOptions -instance CFunctor CPreProcessorConfig -instance CFunctor CConfig - -deriveCZipWith ''CDebugConfig -deriveCZipWith ''CLayoutConfig -deriveCZipWith ''CErrorHandlingConfig -deriveCZipWith ''CForwardOptions -deriveCZipWith ''CPreProcessorConfig -deriveCZipWith ''CConfig diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- These optimizations are disabled to improve compile times (and compilation --- memory usage). When we do not disable them, the CI servers take more than --- 10 minutes to compile this module alone. --- Having looked into aeson and how the instances are written, I still do --- not understand what makes GHC choke so much here. The size of the raw --- expressions below looks fairly negligible, so there must be some expansion --- due to inlining going on. But even disabling INLINE pragmas in aeson did --- not seem to change anything. --- Nonetheless, this solution works and has no downsides because the --- instances defined here are not in any way performance-critical. -{-# OPTIONS_GHC -fno-pre-inlining #-} -{-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fignore-interface-pragmas #-} - -module Language.Haskell.Brittany.Internal.Config.Types.Instances -where - - - -#include "prelude.inc" - -import Data.Yaml -import qualified Data.Aeson.Types as Aeson - -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC.Generics - - - -aesonDecodeOptionsBrittany :: Aeson.Options -aesonDecodeOptionsBrittany = Aeson.defaultOptions - { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (=='_') - } - -#define makeFromJSON(type)\ - instance FromJSON (type) where\ - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany;\ - {-# NOINLINE parseJSON #-} -#define makeToJSON(type)\ - instance ToJSON (type) where\ - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany;\ - {-# NOINLINE toJSON #-};\ - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany;\ - {-# NOINLINE toEncoding #-} - -#define makeFromJSONMaybe(type)\ - instance FromJSON (type Maybe) where\ - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany;\ - {-# NOINLINE parseJSON #-} -#define makeFromJSONOption(type)\ - instance FromJSON (type Option) where\ - parseJSON = fmap (cMap Option) . parseJSON;\ - {-# NOINLINE parseJSON #-} -#define makeToJSONMaybe(type)\ - instance ToJSON (type Maybe) where\ - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany;\ - {-# NOINLINE toJSON #-};\ - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany;\ - {-# NOINLINE toEncoding #-} -#define makeToJSONOption(type)\ - instance ToJSON (type Option) where\ - toJSON = toJSON . cMap getOption;\ - {-# NOINLINE toJSON #-};\ - toEncoding = toEncoding . cMap getOption;\ - {-# NOINLINE toEncoding #-} - - -makeFromJSONOption(CDebugConfig) -makeFromJSONMaybe(CDebugConfig) -makeToJSONOption(CDebugConfig) -makeToJSONMaybe(CDebugConfig) - -makeFromJSON(IndentPolicy) -makeToJSON(IndentPolicy) -makeFromJSON(AltChooser) -makeToJSON(AltChooser) -makeFromJSON(ColumnAlignMode) -makeToJSON(ColumnAlignMode) -makeFromJSON(CPPMode) -makeToJSON(CPPMode) -makeFromJSON(ExactPrintFallbackMode) -makeToJSON(ExactPrintFallbackMode) - -makeFromJSONOption(CLayoutConfig) -makeFromJSONMaybe(CLayoutConfig) -makeToJSONOption(CLayoutConfig) -makeToJSONMaybe(CLayoutConfig) - -makeFromJSONOption(CErrorHandlingConfig) -makeFromJSONMaybe(CErrorHandlingConfig) -makeToJSONOption(CErrorHandlingConfig) -makeToJSONMaybe(CErrorHandlingConfig) - -makeFromJSONOption(CForwardOptions) -makeFromJSONMaybe(CForwardOptions) -makeToJSONOption(CForwardOptions) -makeToJSONMaybe(CForwardOptions) - -makeFromJSONOption(CPreProcessorConfig) -makeFromJSONMaybe(CPreProcessorConfig) -makeToJSONOption(CPreProcessorConfig) -makeToJSONMaybe(CPreProcessorConfig) - -makeFromJSONOption(CConfig) -makeToJSONOption(CConfig) -makeToJSONMaybe(CConfig) - --- This custom instance ensures the "omitNothingFields" behaviour not only for --- leafs, but for nodes of the config as well. This way e.g. "{}" is valid --- config file content. -instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = Config - <$> v .:? Text.pack "conf_version" - <*> v .:?= Text.pack "conf_debug" - <*> v .:?= Text.pack "conf_layout" - <*> v .:?= Text.pack "conf_errorHandling" - <*> v .:?= Text.pack "conf_forward" - <*> v .:?= Text.pack "conf_preprocessor" - <*> v .:? Text.pack "conf_roundtrip_exactprint_only" - <*> v .:? Text.pack "conf_disable_formatting" - <*> v .:? Text.pack "conf_obfuscate" - parseJSON invalid = Aeson.typeMismatch "Config" invalid - --- Pretends that the value is {} when the key is not present. -(.:?=) :: FromJSON a => Object -> Text -> Parser a -o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure - diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Internal.ExactPrintUtils - ( parseModule - , parseModuleFromString - , commentAnnFixTransformGlob - , extractToplevelAnns - , foldedAnnKeys - , withTransformedAnns - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils -import Data.Data -import Data.HList.HList - -import DynFlags ( getDynFlags ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified DynFlags as GHC -import qualified GHC as GHC hiding (parseModule) -import qualified Parser as GHC -import qualified SrcLoc as GHC -import qualified FastString as GHC -import qualified GHC as GHC hiding (parseModule) -import qualified Lexer as GHC -import qualified StringBuffer as GHC -import qualified Outputable as GHC -import qualified CmdLineParser as GHC - -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -import Bag -#else -import HsSyn -#endif - -import SrcLoc ( SrcSpan, Located ) - - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint - -import qualified Data.Generics as SYB - -import Control.Exception --- import Data.Generics.Schemes - - - -parseModule - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule = - parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout - --- | Parse a module with specific instructions for the C pre-processor. -parseModuleWithCpp - :: ExactPrint.CppOptions - -> ExactPrint.DeltaOptions - -> [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModuleWithCpp cpp opts args fp dynCheck = - ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ GHC.getSessionDynFlags - (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine - dflags0 - (GHC.noLoc <$> ("-hide-all-packages" : args)) - -- that we pass -hide-all-packages here is a duplication, because - -- ExactPrint.initDynFlags also does it, but necessary because of - -- stupid and careless GHC API design. We explicitly want to pass - -- our args before calling that, so this is what we do. Should be - -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063. - void $ lift $ GHC.setSessionDynFlags dflags1 - dflags2 <- lift $ ExactPrint.initDynFlags fp - when (not $ null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " - ++ show (leftover <&> \(L _ s) -> s) - when (not $ null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " - ++ show (warnings <&> warnExtractorCompat) - x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 - res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) -#else - either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) -#endif - (\(a, m) -> pure (a, m, x)) - $ ExactPrint.postParseTransform res opts - -parseModuleFromString - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> String - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModuleFromString args fp dynCheck str = - -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will - -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we - -- cannot kill the parsing thread - not very nice. But i'll - -- optimistically assume that most of the time brittany uses noticable or - -- longer time, the majority of the time is not spend in parsing, but in - -- bridoc transformation stuff. - -- (reminder to update note on `parsePrintModule` if this changes.) - mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str - (dflags1, leftover, warnings) <- lift - $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) - when (not $ null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " - ++ show (leftover <&> \(L _ s) -> s) - when (not $ null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " - ++ show (warnings <&> warnExtractorCompat) - dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 - let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str - case res of -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) -#else - Left (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err -#endif - Right (a , m ) -> pure (a, m, dynCheckRes) - - -commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () -commentAnnFixTransformGlob ast = do - let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` - (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) - let nodes = SYB.everything (<>) extract ast - let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (flip const) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span, annKey) <- Foldable.toList nodes - ] - nodes `forM_` (snd .> processComs annsMap) - where - processComs annsMap annKey1 = do - mAnn <- State.Class.gets fst <&> Map.lookup annKey1 - mAnn `forM_` \ann1 -> do - let priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 - let - processCom - :: (ExactPrint.Comment, ExactPrint.DeltaPos) - -> ExactPrint.TransformT Identity Bool - processCom comPair@(com, _) = - case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of - GHC.UnhelpfulLoc{} -> return True -- retain comment at current node. - GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of - Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of - (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> - move $> False - (x, y) | x == y -> move $> False - _ -> return True - where - ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 - ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.srcSpanStart annKeyLoc1 - loc2 = GHC.srcSpanStart annKeyLoc2 - move = ExactPrint.modifyAnnsT $ \anns -> - let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns - ann2' = ann2 - { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] - } - in - Map.insert annKey2 ann2' anns - _ -> return True -- retain comment at current node. - priors' <- flip filterM priors processCom - follows' <- flip filterM follows $ processCom - assocs' <- flip filterM assocs $ \case - (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let ann1' = ann1 { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } - ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns - - --- TODO: this is unused by now, but it contains one detail that --- commentAnnFixTransformGlob does not include: Moving of comments for --- "RecordUpd"s. --- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () --- commentAnnFixTransform modul = SYB.everything (>>) genF modul --- where --- genF :: Data.Data.Data a => a -> ExactPrint.Transform () --- genF = (\_ -> return ()) `SYB.extQ` exprF --- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () --- exprF lexpr@(L _ expr) = case expr of --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> --- #else --- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordUpd _ _e fs@(_:_) -> --- #else --- RecordUpd _e fs@(_:_) _cons _ _ _ -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- _ -> return () - -commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () -commentAnnFixTransform modul = SYB.everything (>>) genF modul - where - genF :: Data.Data.Data a => a -> ExactPrint.Transform () - genF = (\_ -> return ()) `SYB.extQ` exprF - exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () - exprF lexpr@(L _ expr) = case expr of - RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> - moveTrailingComments lexpr (List.last fs) - RecordUpd _ _e fs@(_:_) -> - moveTrailingComments lexpr (List.last fs) - _ -> return () - -moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) - => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () -moveTrailingComments astFrom astTo = do - let - k1 = ExactPrint.mkAnnKey astFrom - k2 = ExactPrint.mkAnnKey astTo - moveComments ans = ans' - where - an1 = Data.Maybe.fromJust $ Map.lookup k1 ans - an2 = Data.Maybe.fromJust $ Map.lookup k2 ans - cs1f = ExactPrint.annFollowingComments an1 - cs2f = ExactPrint.annFollowingComments an2 - (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) - $ \case - (ExactPrint.AnnComment com, dp) -> Left (com, dp) - x -> Right x - an1' = an1 - { ExactPrint.annsDP = nonComments - , ExactPrint.annFollowingComments = [] - } - an2' = an2 - { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments - } - ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - - ExactPrint.modifyAnnsT moveComments - --- | split a set of annotations in a module into a map from top-level module --- elements to the relevant annotations. Avoids quadratic behaviour a trivial --- implementation would have. -extractToplevelAnns - :: Located (HsModule GhcPs) - -> ExactPrint.Anns - -> Map ExactPrint.AnnKey ExactPrint.Anns -extractToplevelAnns lmod anns = output - where - (L _ (HsModule _ _ _ ldecls _ _)) = lmod - declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap1 = Map.unions $ ldecls <&> \ldecl -> - Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) - declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap2 = - Map.fromList - $ [ (captured, declMap1 Map.! k) - | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns - ] - declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns - -groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) -groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) - Map.empty - where - insert k a Nothing = Just (Map.singleton k a) - insert k a (Just m) = Just (Map.insert k a m) - -foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey -foldedAnnKeys ast = SYB.everything - Set.union - ( \x -> maybe - Set.empty - Set.singleton - [ SYB.gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x - | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) - , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x - -- for some reason, ghc-8.8 has forgotten how to infer the type of l, - -- even though it is passed to mkAnnKey above, which only accepts - -- SrcSpan. - ] - ) - ast - where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) - - -withTransformedAnns - :: Data ast - => ast - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case - readers@(conf :+: anns :+: HNil) -> do - -- TODO: implement `local` for MultiReader/MultiRWS - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - x <- m - MultiRWSS.mPutRawR readers - pure x - where - f anns = - let ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced - - -warnExtractorCompat :: GHC.Warn -> String -warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ /dev/null @@ -1,860 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Haskell.Brittany.Internal.LayouterBasics - ( processDefault - , rdrNameToText - , lrdrNameToText - , lrdrNameToTextAnn - , lrdrNameToTextAnnTypeEqualityIsSpecial - , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick - , askIndent - , extractAllComments - , extractRestComments - , filterAnns - , docEmpty - , docLit - , docLitS - , docAlt - , CollectAltM - , addAlternativeCond - , addAlternative - , runFilteredAlternative - , docLines - , docCols - , docSeq - , docPar - , docNodeAnnKW - , docNodeMoveToKWDP - , docWrapNode - , docWrapNodePrior - , docWrapNodeRest - , docForceSingleline - , docForceMultiline - , docEnsureIndent - , docAddBaseY - , docSetBaseY - , docSetIndentLevel - , docSeparator - , docAnnotationPrior - , docAnnotationKW - , docAnnotationRest - , docMoveToKWDP - , docNonBottomSpacing - , docNonBottomSpacingS - , docSetParSpacing - , docForceParSpacing - , docDebug - , docSetBaseAndIndent - , briDocByExact - , briDocByExactNoComment - , briDocByExactInlineOnly - , foldedAnnKeys - , unknownNodeError - , appSep - , docCommaSep - , docParenLSep - , docParenL - , docParenR - , docParenHashLSep - , docParenHashRSep - , docBracketL - , docBracketR - , docTick - , spacifyDocs - , briDocMToPPM - , briDocMToPPMInner - , allocateNode - , docSharedWrapper - , hasAnyCommentsBelow - , hasCommentsBetween - , hasAnyCommentsConnected - , hasAnyCommentsPrior - , hasAnyRegularCommentsConnected - , hasAnyRegularCommentsRest - , hasAnnKeywordComment - , hasAnnKeyword - , astAnn - , allocNodeIndex - ) -where - - - -#include "prelude.inc" - -import qualified Control.Monad.Writer.Strict as Writer - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation, KeywordId ) - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import RdrName ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) -import qualified SrcLoc as GHC -import OccName ( occNameString ) -import Name ( getOccString ) -import Module ( moduleName ) -import ApiAnnotation ( AnnKeywordId(..) ) - -import Data.Data -import Data.Generics.Schemes - -import qualified Data.Char as Char - -import DataTreePrint - -import Data.HList.HList - - - -processDefault - :: ( ExactPrint.Annotate.Annotate ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiReader ExactPrint.Types.Anns m - ) - => Located ast - -> m () -processDefault x = do - anns <- mAsk - let str = ExactPrint.exactPrint x anns - -- this hack is here so our print-empty-module trick does not add - -- a newline at the start if there actually is no module header / imports - -- / anything. - -- TODO: instead the appropriate annotation could be removed when "cleaning" - -- the module (header). This would remove the need for this hack! - case str of - "\n" -> return () - _ -> mTell $ Text.Builder.fromString str - --- | Use ExactPrint's output for this node; add a newly generated inline comment --- at insertion position (meant to point out to the user that this node is --- not handled by brittany yet). Useful when starting implementing new --- syntactic constructs when children are not handled yet. -briDocByExact - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ToBriDocM BriDocNumbered -briDocByExact ast = do - anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - docExt ast anns True - --- | Use ExactPrint's output for this node. --- Consider that for multi-line input, the indentation of the code produced --- by ExactPrint might be different, and even incompatible with the indentation --- of its surroundings as layouted by brittany. But there are safe uses of --- this, e.g. for any top-level declarations. -briDocByExactNoComment - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ToBriDocM BriDocNumbered -briDocByExactNoComment ast = do - anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - docExt ast anns False - --- | Use ExactPrint's output for this node, presuming that this output does --- not contain any newlines. If this property is not met, the semantics --- depend on the @econf_AllowRiskyExactPrintUse@ config flag. -briDocByExactInlineOnly - :: (ExactPrint.Annotate.Annotate ast, Data ast) - => String - -> Located ast - -> ToBriDocM BriDocNumbered -briDocByExactInlineOnly infoStr ast = do - anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns - fallbackMode <- - mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t - let errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit - $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" - case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _ ) -> errorAction - (_ , [t]) -> exactPrintNode - (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) - (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted - _ -> errorAction - -rdrNameToText :: RdrName -> Text --- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr -rdrNameToText (Unqual occname) = Text.pack $ occNameString occname -rdrNameToText (Qual mname occname) = - Text.pack $ moduleNameString mname ++ "." ++ occNameString occname -rdrNameToText (Orig modul occname) = - Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname -rdrNameToText (Exact name) = Text.pack $ getOccString name - -lrdrNameToText :: GenLocated l RdrName -> Text -lrdrNameToText (L _ n) = rdrNameToText n - -lrdrNameToTextAnnGen - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => (Text -> Text) - -> Located RdrName - -> m Text -lrdrNameToTextAnnGen f ast@(L _ n) = do - anns <- mAsk - let t = f $ rdrNameToText n - let hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False - -- TODO: in general: we should _always_ process all annotaiton stuff here. - -- whatever we don't probably should have had some effect on the - -- output. in such cases, resorting to byExact is probably the safe - -- choice. - return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" - _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t - -lrdrNameToTextAnn - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName - -> m Text -lrdrNameToTextAnn = lrdrNameToTextAnnGen id - -lrdrNameToTextAnnTypeEqualityIsSpecial - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName - -> m Text -lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - lrdrNameToTextAnnGen f ast - --- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects --- the annotations for a (parent) node for a tick to be added to the --- literal. --- Excessively long name to reflect on us having to work around such --- excessively obscure special cases in the exactprint API. -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick - :: ( Data ast - , MonadMultiReader Config m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => Located ast - -> Located RdrName - -> m Text -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do - hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - return $ if hasQuote then Text.cons '\'' lit else lit - -askIndent :: (MonadMultiReader Config m) => m Int -askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk - - -extractAllComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] -extractAllComments ann = - ExactPrint.annPriorComments ann ++ extractRestComments ann - -extractRestComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] -extractRestComments ann = - ExactPrint.annFollowingComments ann - ++ (ExactPrint.annsDP ann >>= \case - (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] - ) - -filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) - --- | True if there are any comments that are --- a) connected to any node below (in AST sense) the given node AND --- b) after (in source code order) the node. -hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsBelow ast@(L l _) = - List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) - <$> astConnectedComments ast - -hasCommentsBetween - :: Data ast - => GHC.Located ast - -> AnnKeywordId - -> AnnKeywordId - -> ToBriDocM Bool -hasCommentsBetween ast leftKey rightKey = do - mAnn <- astAnn ast - let go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest - case mAnn of - Nothing -> pure False - Just ann -> pure $ go1 $ ExactPrint.annsDP ann - --- | True if there are any comments that are connected to any node below (in AST --- sense) the given node -hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast - --- | True if there are any regular comments connected to any node below (in AST --- sense) the given node -hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsConnected ast = - any isRegularComment <$> astConnectedComments ast - --- | Regular comments are comments that are actually "source code comments", --- i.e. things that start with "--" or "{-". In contrast to comment-annotations --- used by ghc-exactprint for capturing symbols (and their exact positioning). --- --- Only the type instance layouter makes use of this filter currently, but --- it might make sense to apply it more aggressively or make it the default - --- I believe that most of the time we branch on the existence of comments, we --- only care about "regular" comments. We simply did not need the distinction --- because "irregular" comments are not that common outside of type/data decls. -isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool -isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst - -astConnectedComments - :: Data ast - => GHC.Located ast - -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] -astConnectedComments ast = do - anns <- filterAnns ast <$> mAsk - pure $ extractAllComments =<< Map.elems anns - -hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsPrior ast = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors - -hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsRest ast = astAnn ast <&> \case - Nothing -> False - Just ann -> any isRegularComment (extractRestComments ann) - -hasAnnKeywordComment - :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just ann -> any hasK (extractAllComments ann) - where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst - -hasAnnKeyword - :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) - => Located a - -> AnnKeywordId - -> m Bool -hasAnnKeyword ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks - where - hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - -astAnn - :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) - => GHC.Located ast - -> m (Maybe Annotation) -astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk - --- new BriDoc stuff - -allocateNode - :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered -allocateNode bd = do - i <- allocNodeIndex - return (i, bd) - -allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int -allocNodeIndex = do - NodeAllocIndex i <- mGet - mSet $ NodeAllocIndex (i + 1) - return i - --- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docEmpty = allocateNode BDFEmpty --- --- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered --- docLit t = allocateNode $ BDFLit t --- --- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) --- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered --- docExt x anns shouldAddComment = allocateNode $ BDFExternal --- (ExactPrint.Types.mkAnnKey x) --- (foldedAnnKeys x) --- shouldAddComment --- (Text.pack $ ExactPrint.exactPrint x anns) --- --- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docAlt l = allocateNode . BDFAlt =<< sequence l --- --- --- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docSeq l = allocateNode . BDFSeq =<< sequence l --- --- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docLines l = allocateNode . BDFLines =<< sequence l --- --- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered --- docCols sig l = allocateNode . BDFCols sig =<< sequence l --- --- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered --- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm --- --- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm --- --- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm --- --- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docSeparator = allocateNode BDFSeparator --- --- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered --- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm --- --- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered --- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm --- --- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm --- --- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- appSep x = docSeq [x, docSeparator] --- --- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docCommaSep = appSep $ docLit $ Text.pack "," --- --- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docParenLSep = appSep $ docLit $ Text.pack "(" --- --- --- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) --- => Located ast --- -> m BriDocNumbered --- -> m BriDocNumbered --- docPostComment ast bdm = do --- bd <- bdm --- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd --- --- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) --- => Located ast --- -> m BriDocNumbered --- -> m BriDocNumbered --- docWrapNode ast bdm = do --- bd <- bdm --- i1 <- allocNodeIndex --- i2 <- allocNodeIndex --- return --- $ (,) i1 --- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) --- $ (,) i2 --- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) --- $ bd --- --- docPar :: MonadMultiState NodeAllocIndex m --- => m BriDocNumbered --- -> m BriDocNumbered --- -> m BriDocNumbered --- docPar lineM indentedM = do --- line <- lineM --- indented <- indentedM --- allocateNode $ BDFPar BrIndentNone line indented --- --- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm --- --- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm --- --- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered --- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd - -docEmpty :: ToBriDocM BriDocNumbered -docEmpty = allocateNode BDFEmpty - -docLit :: Text -> ToBriDocM BriDocNumbered -docLit t = allocateNode $ BDFLit t - -docLitS :: String -> ToBriDocM BriDocNumbered -docLitS s = allocateNode $ BDFLit $ Text.pack s - -docExt - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ExactPrint.Types.Anns - -> Bool - -> ToBriDocM BriDocNumbered -docExt x anns shouldAddComment = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey x) - (foldedAnnKeys x) - shouldAddComment - (Text.pack $ ExactPrint.exactPrint x anns) - -docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docAlt l = allocateNode . BDFAlt =<< sequence l - -newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) - deriving (Functor, Applicative, Monad) - -addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = - when cond (addAlternative doc) - -addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = - CollectAltM . Writer.tell . (: []) - -runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered -runFilteredAlternative (CollectAltM action) = - docAlt $ Writer.execWriter action - - -docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docSeq [] = docEmpty -docSeq l = allocateNode . BDFSeq =<< sequence l - -docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docLines l = allocateNode . BDFLines =<< sequence l - -docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docCols sig l = allocateNode . BDFCols sig =<< sequence l - -docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm - -docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetBaseY bdm = do - bd <- bdm - -- the order here is important so that these two nodes can be treated - -- properly over at `transformAlts`. - n1 <- allocateNode $ BDFBaseYPushCur bd - n2 <- allocateNode $ BDFBaseYPop n1 - return n2 - -docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetIndentLevel bdm = do - bd <- bdm - n1 <- allocateNode $ BDFIndentLevelPushCur bd - n2 <- allocateNode $ BDFIndentLevelPop n1 - return n2 - -docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetBaseAndIndent = docSetBaseY . docSetIndentLevel - -docSeparator :: ToBriDocM BriDocNumbered -docSeparator = allocateNode BDFSeparator - -docAnnotationPrior - :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationPrior annKey bdm = - allocateNode . BDFAnnotationPrior annKey =<< bdm - -docAnnotationKW - :: AnnKey - -> Maybe AnnKeywordId - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm - -docMoveToKWDP - :: AnnKey - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docMoveToKWDP annKey kw shouldRestoreIndent bdm = - allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm - -docAnnotationRest - :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm - -docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm - -docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm - -docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm - -docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm - -docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docDebug s bdm = allocateNode . BDFDebug s =<< bdm - -appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -appSep x = docSeq [x, docSeparator] - -docCommaSep :: ToBriDocM BriDocNumbered -docCommaSep = appSep $ docLit $ Text.pack "," - -docParenLSep :: ToBriDocM BriDocNumbered -docParenLSep = appSep docParenL - --- TODO: we don't make consistent use of these (yet). However, I think the --- most readable approach overall might be something else: define --- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. --- I think those two would make the usage most readable. --- lit "(" and appSep (lit "(") are understandable and short without --- introducing a new top-level binding for all types of parentheses. -docParenL :: ToBriDocM BriDocNumbered -docParenL = docLit $ Text.pack "(" - -docParenR :: ToBriDocM BriDocNumbered -docParenR = docLit $ Text.pack ")" - -docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] - -docParenHashRSep :: ToBriDocM BriDocNumbered -docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] - -docBracketL :: ToBriDocM BriDocNumbered -docBracketL = docLit $ Text.pack "[" - -docBracketR :: ToBriDocM BriDocNumbered -docBracketR = docLit $ Text.pack "]" - - -docTick :: ToBriDocM BriDocNumbered -docTick = docLit $ Text.pack "'" - -docNodeAnnKW - :: Data.Data.Data ast - => Located ast - -> Maybe AnnKeywordId - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docNodeAnnKW ast kw bdm = - docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm - -docNodeMoveToKWDP - :: Data.Data.Data ast - => Located ast - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm - -class DocWrapable a where - docWrapNode :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - docWrapNodePrior :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - docWrapNodeRest :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - -instance DocWrapable (ToBriDocM BriDocNumbered) where - docWrapNode ast bdm = do - bd <- bdm - i1 <- allocNodeIndex - i2 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd - docWrapNodePrior ast bdm = do - bd <- bdm - i1 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ bd - docWrapNodeRest ast bdm = do - bd <- bdm - i2 <- allocNodeIndex - return - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd - -instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where - docWrapNode ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNode ast bd] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> - [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] - _ -> error "cannot happen (TM)" - docWrapNodePrior ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNodePrior ast bd] - (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR - docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR - -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where - docWrapNode ast bdsm = do - bds <- bdsm - case bds of - [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. - [bd] -> do - bd' <- docWrapNode ast (return bd) - return [bd'] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do - bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) - return $ [bd1'] ++ reverse bdM ++ [bdN'] - _ -> error "cannot happen (TM)" - docWrapNodePrior ast bdsm = do - bds <- bdsm - case bds of - [] -> return [] - (bd1:bdR) -> do - bd1' <- docWrapNodePrior ast (return bd1) - return (bd1':bdR) - docWrapNodeRest ast bdsm = do - bds <- bdsm - case reverse bds of - [] -> return [] - (bdN:bdR) -> do - bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN':bdR) - -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where - docWrapNode ast bdsm = do - bds <- bdsm - case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. - bd1 Seq.:< rest -> case Seq.viewr rest of - Seq.EmptyR -> do - bd1' <- docWrapNode ast (return bd1) - return $ Seq.singleton bd1' - bdM Seq.:> bdN -> do - bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) - return $ (bd1' Seq.<| bdM) Seq.|> bdN' - docWrapNodePrior ast bdsm = do - bds <- bdsm - case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty - bd1 Seq.:< bdR -> do - bd1' <- docWrapNodePrior ast (return bd1) - return $ bd1' Seq.<| bdR - docWrapNodeRest ast bdsm = do - bds <- bdsm - case Seq.viewr bds of - Seq.EmptyR -> return Seq.empty - bdR Seq.:> bdN -> do - bdN' <- docWrapNodeRest ast (return bdN) - return $ bdR Seq.|> bdN' - -instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where - docWrapNode ast stuffM = do - (bds, bd, x) <- stuffM - if null bds - then do - bd' <- docWrapNode ast (return bd) - return (bds, bd', x) - else do - bds' <- docWrapNodePrior ast (return bds) - bd' <- docWrapNodeRest ast (return bd) - return (bds', bd', x) - docWrapNodePrior ast stuffM = do - (bds, bd, x) <- stuffM - bds' <- docWrapNodePrior ast (return bds) - return (bds', bd, x) - docWrapNodeRest ast stuffM = do - (bds, bd, x) <- stuffM - bd' <- docWrapNodeRest ast (return bd) - return (bds, bd', x) - - - -docPar - :: ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docPar lineM indentedM = do - line <- lineM - indented <- indentedM - allocateNode $ BDFPar BrIndentNone line indented - -docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm - -docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm - -docEnsureIndent - :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd - -unknownNodeError - :: Data.Data.Data ast - => String - -> GenLocated GHC.SrcSpan ast - -> ToBriDocM BriDocNumbered -unknownNodeError infoStr ast = do - mTell [ErrorUnknownNode infoStr ast] - docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" - -spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] -spacifyDocs [] = [] -spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] - -briDocMToPPM :: ToBriDocM a -> PPMLocal a -briDocMToPPM m = do - (x, errs, debugs) <- briDocMToPPMInner m - mTell debugs - mTell errs - return x - -briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) -briDocMToPPMInner m = do - readers <- MultiRWSS.mGetRawR - let ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m - pure (x, errs, debugs) - -docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) -docSharedWrapper f x = return <$> f x diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE KindSignatures #-} - -module Language.Haskell.Brittany.Internal.Layouters.DataDecl - ( layoutDataDecl - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import RdrName ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) -import qualified GHC -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name -import BasicTypes -import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) - -import Language.Haskell.Brittany.Internal.Layouters.Type -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Utils - -import Bag ( mapBagM ) - - - -layoutDataDecl - :: Located (TyClDecl GhcPs) - -> Located RdrName - -> LHsQTyVars GhcPs - -> HsDataDefn GhcPs - -> ToBriDocM BriDocNumbered -layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext -layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of - -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> - docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- fmap return $ createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- fmap return $ createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl - - - -- data MyData a b - -- (zero constructors) - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> - docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- fmap return $ createBndrDoc bndrs - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "data" - , lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - ] - - -- data MyData = MyData .. - -- data MyData = MyData { .. } - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> - case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> - docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- fmap return $ createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of - Nothing -> pure Nothing - Just x -> Just . pure <$> x - rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing - Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- fmap return $ createDetailsDoc consNameStr details - consDoc <- fmap pure - $ docNonBottomSpacing - $ case (forallDocMay, rhsContextDocMay) of - (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] - , docSeq - [ docLitS "." - , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] - ] - ] - (Just forallDoc, Nothing) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] - , docSeq [docLitS ".", docSeparator, rhsDoc] - ] - (Nothing, Just rhsContextDoc) -> docSeq - [ docLitS "=" - , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] - ] - (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] - createDerivingPar mDerivs $ docAlt - [ -- data D = forall a . Show a => D a - docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline $ lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - ] - , docLitS "=" - , docSeparator - , docSetIndentLevel $ docSeq - [ case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc - ] - ] - , -- data D - -- = forall a . Show a => D a - docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline lhsContextDoc - , appSep $ docLit nameStr - , tyVarLine - ] - ) - ( docSeq - [ docLitS "=" - , docSeparator - , docSetIndentLevel $ docSeq - [ case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc - ] - ] - ) - , -- data D - -- = forall a - -- . Show a => - -- D a - docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline lhsContextDoc - , appSep $ docLit nameStr - , tyVarLine - ] - ) - consDoc - , -- data - -- Show a => - -- D - -- = forall a - -- . Show a => - -- D a - -- This alternative is only for -XDatatypeContexts. - -- But I think it is rather unlikely this will trigger without - -- -XDataTypeContexts, especially with the `docNonBottomSpacing` - -- above, so while not strictly necessary, this should not - -- hurt. - docAddBaseY BrIndentRegular $ docPar - (docLitS "data") - ( docLines - [ lhsContextDoc - , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLit nameStr - , tyVarLine - ] - , consDoc - ] - ) - ] - _ -> briDocByExactNoComment ltycl - - _ -> briDocByExactNoComment ltycl - -createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered -createContextDoc [] = docEmpty -createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] -createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 - tRDocs <- tR `forM` docSharedWrapper layoutType - docAlt - [ docSeq - [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse docCommaSep - (t1Doc : tRDocs) - , docLitS ") =>" - , docSeparator - ] - , docLines $ join - [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs - <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] - , [docLitS ") =>", docSeparator] - ] - ] - -createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered -createBndrDoc bs = do - tyVarDocs <- bs `forM` \case - (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar _ext lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - (L _ (XTyVarBndr ext)) -> absurdExt ext - docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] - -createDerivingPar - :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -createDerivingPar derivs mainDoc = do - case derivs of - (L _ []) -> mainDoc - (L _ types) -> - docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc - <$> types - -derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext -derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of - (L _ []) -> docSeq [] - (L _ ts) -> - let - tsLength = length ts - whenMoreThan1Type val = - if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in - docSeq - [ docDeriving - , docWrapNodePrior types $ lhsStrategy - , docSeparator - , whenMoreThan1Type "(" - , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts <&> \case - HsIB _ t -> layoutType t - XHsImplicitBndrs x -> absurdExt x - , whenMoreThan1Type ")" - , rhsStrategy - ] - where - strategyLeftRight = \case - (L _ StockStrategy ) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes) ) -> - ( docEmpty - , case viaTypes of - HsIB _ext t -> docSeq - [ docWrapNode lVia $ docLitS " via" - , docSeparator - , layoutType t - ] - XHsImplicitBndrs ext -> absurdExt ext - ) - -docDeriving :: ToBriDocM BriDocNumbered -docDeriving = docLitS "deriving" - -createDetailsDoc - :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) -createDetailsDoc consNameStr details = case details of - PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let - singleLine = docSeq - [ docLit consNameStr - , docSeparator - , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ args <&> layoutType - ] - leftIndented = docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType <$> args - multiAppended = docSeq - [ docLit consNameStr - , docSeparator - , docSetBaseY $ docLines $ layoutType <$> args - ] - multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - (docLit consNameStr) - (docLines $ layoutType <$> args) - case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] - IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] - IndentPolicyFree -> - docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_:_)) -> do - let ((fName1, fType1) : fDocR) = mkFieldDocs fields - -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack - let allowSingleline = False - docAddBaseY BrIndentRegular - $ runFilteredAlternative - $ do - -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" - ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 - , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 - ] - , docSeq - [ docLitS "{" - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) - ] - ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType - ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] - , docLitS "}" - ] - ) - InfixCon arg1 arg2 -> docSeq - [ layoutType arg1 - , docSeparator - , docLit consNameStr - , docSeparator - , layoutType arg2 - ] - where - mkFieldDocs - :: [LConDeclField GhcPs] - -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] - mkFieldDocs = fmap $ \lField -> case lField of - L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t - L _ (XConDeclField x) -> absurdExt x - -createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = Just $ docSeq - [docLitS "forall ", createBndrDoc lhsTyVarBndrs] - -createNamesAndTypeDoc - :: Data.Data.Data ast - => Located ast - -> [GenLocated t (FieldOcc GhcPs)] - -> Located (HsType GhcPs) - -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -createNamesAndTypeDoc lField names t = - ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \case - L _ (XFieldOcc x) -> absurdExt x - L _ (FieldOcc _ fieldName) -> - docLit =<< lrdrNameToTextAnn fieldName - ] - , docWrapNodeRest lField $ layoutType t - ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ /dev/null @@ -1,1028 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} - -module Language.Haskell.Brittany.Internal.Layouters.Decl - ( layoutDecl - , layoutSig - , layoutBind - , layoutLocalBinds - , layoutGuardLStmt - , layoutPatternBind - , layoutGrhs - , layoutPatternBindFinal - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Layouters.Type - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.Utils - -import GHC ( runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - ) -import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) -import qualified FastString -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -import GHC.Hs.Extension (NoExtField (..)) -#else -import HsSyn -import HsExtension (NoExt (..)) -#endif -import Name -import BasicTypes ( InlinePragma(..) - , Activation(..) - , InlineSpec(..) - , RuleMatchInfo(..) - , LexicalFixity(..) - ) -import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) - -import Language.Haskell.Brittany.Internal.Layouters.Type -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.DataDecl - -import Bag ( mapBagM, bagToList, emptyBag ) -import Data.Char (isUpper) - - - -layoutDecl :: ToBriDoc HsDecl -layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) - ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD _ (TyFamInstD _ tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False d tfid - InstD _ (ClsInstD _ inst) -> - withTransformedAnns d $ layoutClsInst (L loc inst) - _ -> briDocByExactNoComment d - --------------------------------------------------------------------------------- --- Sig --------------------------------------------------------------------------------- - -layoutSig :: ToBriDoc Sig -layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ - InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> - docWrapNode lsig $ do - nameStr <- lrdrNameToTextAnn name - specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " - docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) - <> nameStr - <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ - _ -> briDocByExactNoComment lsig -- TODO - where - layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] - nameStrs <- names `forM` lrdrNameToTextAnn - let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- mAsk - <&> _conf_layout - .> _lconfig_hangingTypeSignature - .> confUnpack - if shouldBeHanging - then docSeq $ - [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ] - ] - else layoutLhsAndType - hasComments - (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) - "::" - typeDoc - -specStringCompat - :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String -specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " - -layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) -layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body - BindStmt _ lPat expr _ _ -> do - patDoc <- docSharedWrapper layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docCols ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO - - --------------------------------------------------------------------------------- --- HsBind --------------------------------------------------------------------------------- - -layoutBind - :: ToBriDocC - (HsBindLR GhcPs GhcPs) - (Either [BriDocNumbered] BriDocNumbered) -layoutBind lbind@(L _ bind) = case bind of - FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" - funcPatDocs <- - docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches - return $ Left $ funcPatDocs - PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat - clauseDocs <- layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lbind, d) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" - hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments -#if MIN_VERSION_ghc(8,8,0) - PatSynBind _ (PSB _ patID lpat rpat dir) -> do -#else - PatSynBind _ (PSB _ patID lpat rpat dir) -> do -#endif - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID - lpat - dir - rpat - _ -> Right <$> unknownNodeError "" lbind -layoutIPBind :: ToBriDoc IPBind -layoutIPBind lipbind@(L _ bind) = case bind of - XIPBind{} -> unknownNodeError "XIPBind" lipbind - IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" - IPBind _ (Left (L _ (HsIPName name))) expr -> do - ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name - binderDoc <- docLit $ Text.pack "=" - exprDoc <- layoutExpr expr - hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments - - -data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) - | BagSig (LSig GhcPs) - -bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan -bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l - -layoutLocalBinds - :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) -layoutLocalBinds lbinds@(L _ binds) = case binds of - -- HsValBinds (ValBindsIn lhsBindsLR []) -> - -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering - -- x@(HsValBinds (ValBindsIn{})) -> - -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x - HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered - docs <- docWrapNode lbinds $ join <$> ordered `forM` \case - BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s - return $ Just $ docs --- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> - HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - XHsLocalBindsLR{} -> error "brittany internal error: XHsLocalBindsLR" - x@(HsIPBinds _ XHsIPBinds{}) -> - Just . (: []) <$> unknownNodeError "XHsIPBinds" (L noSrcSpan x) - HsIPBinds _ (IPBinds _ bb) -> - Just <$> mapM layoutIPBind bb - EmptyLocalBinds{} -> return $ Nothing - --- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is --- parSpacing stuff.B -layoutGrhs - :: LGRHS GhcPs (LHsExpr GhcPs) - -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) -layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do - guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body - return (guardDocs, bodyDoc, body) -layoutGrhs (L _ (XGRHS{})) = error "brittany internal error: XGRHS" - -layoutPatternBind - :: Maybe Text - -> BriDocNumbered - -> LMatch GhcPs (LHsExpr GhcPs) - -> ToBriDocM BriDocNumbered -layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match - let (GRHSs _ grhss whereBinds) = m_grhss match - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p - let isInfix = isInfixMatch match - mIdStr <- case match of - Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId - _ -> pure Nothing - let mIdStr' = fixPatternBindIdentifier match <$> mIdStr - patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1:p2:pr) | isInfix -> if null pr - then - docCols ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else - docCols ColPatternsFuncInfix - ( [docCols ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR - ] - ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) - (Just idStr, []) -> docLit idStr - (Just idStr, ps) -> - docCols ColPatternsFuncPrefix - $ appSep (docLit $ idStr) - : (spacifyDocs $ docForceSingleline <$> ps) - (Nothing, ps) -> - docCols ColPatterns - $ (List.intersperse docSeparator $ docForceSingleline <$> ps) - clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) - let alignmentToken = if null pats then Nothing else funId - hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments - -fixPatternBindIdentifier - :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text -fixPatternBindIdentifier match idStr = go $ m_ctxt match - where - go = \case - (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr - (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1 ) -> goInner ctx1 - _ -> idStr - -- I have really no idea if this path ever occurs, but better safe than - -- risking another "drop bangpatterns" bugs. - goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 - (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr - -layoutPatternBindFinal - :: Maybe Text - -> BriDocNumbered - -> Maybe BriDocNumbered - -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) - -- ^ AnnKey for the node that contains the AnnWhere position annotation - -> Bool - -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do - let patPartInline = case mPatDoc of - Nothing -> [] - Just patDoc -> [appSep $ docForceSingleline $ return patDoc] - patPartParWrap = case mPatDoc of - Nothing -> id - Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- mAsk - <&> _conf_layout - .> _lconfig_indentWhereSpecial - .> confUnpack - regularIndentAmount <- mAsk - <&> _conf_layout - .> _lconfig_indentAmount - .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> fmap (pure . pure) $ docAlt - [ docEnsureIndent BrIndentRegular - $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty - [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse docCommaSep - (docForceSingleline . return <$> gs) - ) - wherePart = case mWhereDocs of - Nothing -> Just docEmpty - Just (_, [w]) -> Just $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> Nothing - - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack - - runFilteredAlternative $ do - - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' - ] - ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine - - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1:gr) -> - ( docSeq [appSep $ docLit $ Text.pack "|", return g1] - : ( gr - <&> \g -> - docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - --- | Layout a pattern synonym binding -layoutPatSynBind - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) - -> HsPatSynDir GhcPs - -> LPat GhcPs - -> ToBriDocM BriDocNumbered -layoutPatSynBind name patSynDetails patDir rpat = do - let patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" - mWhereDocs <- layoutPatSynWhere patDir - headDoc <- fmap pure $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] - runFilteredAlternative $ do - addAlternative $ - -- pattern .. where - -- .. - -- .. - docAddBaseY BrIndentRegular $ docSeq - ( [headDoc, docSeparator, body] - ++ case mWhereDocs of - Just ds -> [docSeparator, docPar whereDoc (docLines ds)] - Nothing -> [] - ) - addAlternative $ - -- pattern .. = - -- .. - -- pattern .. <- - -- .. where - -- .. - -- .. - docAddBaseY BrIndentRegular $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) - ) - --- | Helper method for the left hand side of a pattern synonym -layoutLPatSyn - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) - -> ToBriDocM BriDocNumbered -layoutLPatSyn name (PrefixCon vars) = do - docName <- lrdrNameToTextAnn name - names <- mapM lrdrNameToTextAnn vars - docSeq . fmap appSep $ docLit docName : (docLit <$> names) -layoutLPatSyn name (InfixCon left right) = do - leftDoc <- lrdrNameToTextAnn left - docName <- lrdrNameToTextAnn name - rightDoc <- lrdrNameToTextAnn right - docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] -layoutLPatSyn name (RecCon recArgs) = do - docName <- lrdrNameToTextAnn name - args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq . fmap docLit - $ [docName, Text.pack " { " ] - <> intersperse (Text.pack ", ") args - <> [Text.pack " }"] - --- | Helper method to get the where clause from of explicitly bidirectional --- pattern synonyms -layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) -layoutPatSynWhere hs = case hs of - ExplicitBidirectional (MG _ (L _ lbinds) _) -> do - binderDoc <- docLit $ Text.pack "=" - Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds - _ -> pure Nothing - --------------------------------------------------------------------------------- --- TyClDecl --------------------------------------------------------------------------------- - -layoutTyCl :: ToBriDoc TyClDecl -layoutTyCl ltycl@(L _loc tycl) = case tycl of - SynDecl _ name vars fixity typ -> do - let isInfix = case fixity of - Prefix -> False - Infix -> True - -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP - -- let parenWrapper = if hasTrailingParen - -- then appSep . docWrapNodeRest ltycl - -- else id - let wrapNodeRest = docWrapNodeRest ltycl - docWrapNodePrior ltycl - $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ - DataDecl _ext name tyVars _ dataDefn -> - layoutDataDecl ltycl name tyVars dataDefn - _ -> briDocByExactNoComment ltycl - -layoutSynDecl - :: Bool - -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) - -> Located (IdP GhcPs) - -> [LHsTyVarBndr GhcPs] - -> LHsType GhcPs - -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix wrapNodeRest name vars typ = do - nameStr <- lrdrNameToTextAnn name - let - lhs = appSep . wrapNodeRest $ if isInfix - then do - let (a : b : rest) = vars - hasOwnParens <- hasAnnKeywordComment a AnnOpenP - -- This isn't quite right, but does give syntactically valid results - let needsParens = not (null rest) || hasOwnParens - docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - ] - ++ [ docParenL | needsParens ] - ++ [ layoutTyVarBndr False a - , docSeparator - , docLit nameStr - , docSeparator - , layoutTyVarBndr False b - ] - ++ [ docParenR | needsParens ] - ++ fmap (layoutTyVarBndr True) rest - else - docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] - ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsConnected typ - layoutLhsAndType hasComments sharedLhs "=" typeDoc - -layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr -layoutTyVarBndr needsSep lbndr@(L _ bndr) = do - docWrapNodePrior lbndr $ case bndr of - XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" - UserTyVar _ name -> do - nameStr <- lrdrNameToTextAnn name - docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] - KindedTyVar _ name kind -> do - nameStr <- lrdrNameToTextAnn name - docSeq - $ [ docSeparator | needsSep ] - ++ [ docLit $ Text.pack "(" - , appSep $ docLit nameStr - , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind - , docLit $ Text.pack ")" - ] - - --------------------------------------------------------------------------------- --- TyFamInstDecl --------------------------------------------------------------------------------- - - - -layoutTyFamInstDecl - :: Data.Data.Data a - => Bool - -> Located a - -> TyFamInstDecl GhcPs - -> ToBriDocM BriDocNumbered -layoutTyFamInstDecl inClass outerNode tfid = do - let -#if MIN_VERSION_ghc(8,8,0) - FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid - -- bndrsMay isJust e.g. with - -- type instance forall a . MyType (Maybe a) = Either () a - innerNode = outerNode -#else - FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid - bndrsMay = Nothing - innerNode = outerNode -#endif - docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name - needsParens <- hasAnnKeyword outerNode AnnOpenP - let - instanceDoc = if inClass - then docLit $ Text.pack "type" - else docSeq - [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] - makeForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered - makeForallDoc bndrs = do - bndrDocs <- layoutTyVarBndrs bndrs - docSeq - ( [docLit (Text.pack "forall")] - ++ processTyVarBndrsSingleline bndrDocs - ) - lhs = - docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] - ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] - ++ [ docParenL | needsParens ] - ++ [appSep $ docWrapNode name $ docLit nameStr] - ++ intersperse docSeparator (layoutHsTyPats pats) - ++ [ docParenR | needsParens ] - hasComments <- (||) - <$> hasAnyRegularCommentsConnected outerNode - <*> hasAnyRegularCommentsRest innerNode - typeDoc <- docSharedWrapper layoutType typ - layoutLhsAndType hasComments lhs "=" typeDoc - - -#if MIN_VERSION_ghc(8,8,0) -layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] -layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm - HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] - -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change - -- is a bit strange. Hopefully this does not ignore any important - -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" -#else -layoutHsTyPats :: [LHsType GhcPs] -> [ToBriDocM BriDocNumbered] -layoutHsTyPats pats = layoutType <$> pats -#endif - --------------------------------------------------------------------------------- --- ClsInstDecl --------------------------------------------------------------------------------- - --- | Layout an @instance@ declaration --- --- Layout signatures and bindings using the corresponding layouters from the --- top-level. Layout the instance head, type family instances, and data family --- instances using ExactPrint. -layoutClsInst :: ToBriDoc ClsInstDecl -layoutClsInst lcid@(L _ cid) = docLines - [ layoutInstanceHead - , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) - ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) - ] - where - layoutInstanceHead :: ToBriDocM BriDocNumbered -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - layoutInstanceHead = - briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren - <$> lcid -#else - layoutInstanceHead = - briDocByExactNoComment - $ InstD NoExt - . ClsInstD NoExt - . removeChildren - <$> lcid -#endif - - removeChildren :: ClsInstDecl p -> ClsInstDecl p - removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] - , cid_datafam_insts = [] - } - - -- | Like 'docLines', but sorts the lines based on location - docSortedLines - :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered - docSortedLines l = - allocateNode . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l - - layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) - layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig - - layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) - layoutAndLocateBind lbind@(L loc _) = - L loc <$> (joinBinds =<< layoutBind lbind) - - joinBinds - :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered - joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n - - layoutAndLocateTyFamInsts - :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateTyFamInsts ltfid@(L loc tfid) = - L loc <$> layoutTyFamInstDecl True ltfid tfid - - layoutAndLocateDataFamInsts - :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateDataFamInsts ldfid@(L loc _) = - L loc <$> layoutDataFamInstDecl ldfid - - -- | Send to ExactPrint then remove unecessary whitespace - layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl - layoutDataFamInstDecl ldfid = - fmap stripWhitespace <$> briDocByExactNoComment ldfid - - -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations - stripWhitespace :: BriDocF f -> BriDocF f - stripWhitespace (BDFExternal ann anns b t) = - BDFExternal ann anns b $ stripWhitespace' t - stripWhitespace b = b - - -- | This fixes two issues of output coming from Exactprinting - -- associated (data) type decls. Firstly we place the output into docLines, - -- so one newline coming from Exactprint is superfluous, so we drop the - -- first (empty) line. The second issue is Exactprint indents the first - -- member in a strange fashion: - -- - -- input: - -- - -- > instance MyClass Int where - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- output of just exactprinting the associated data type syntax node - -- - -- > - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- To fix this, we strip whitespace from the start of the comments and the - -- first line of the declaration, stopping when we see "data" or "type" at - -- the start of a line. I.e., this function yields - -- - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- Downside apart from being a hacky and brittle fix is that this removes - -- possible additional indentation from comments before the first member. - -- - -- But the whole thing is just a temporary measure until brittany learns - -- to layout data/type decls. - stripWhitespace' :: Text -> Text - stripWhitespace' t = - Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t - where - go [] = [] - go (line1 : lineR) = case Text.stripStart line1 of - st | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR - isTypeOrData t' = - (Text.pack "type" `Text.isPrefixOf` t') - || (Text.pack "newtype" `Text.isPrefixOf` t') - || (Text.pack "data" `Text.isPrefixOf` t') - - --------------------------------------------------------------------------------- --- Common Helpers --------------------------------------------------------------------------------- - -layoutLhsAndType - :: Bool - -> ToBriDocM BriDocNumbered - -> String - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -layoutLhsAndType hasComments lhs sep typeDoc = do - runFilteredAlternative $ do - -- (separators probably are "=" or "::") - -- lhs = type - -- lhs :: type - addAlternativeCond (not hasComments) $ docSeq - [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] - -- lhs - -- :: typeA - -- -> typeB - -- lhs - -- = typeA - -- -> typeB - addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols - ColTyOpPrefix - [ appSep $ docLitS sep - , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc - ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ /dev/null @@ -1,1165 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} - -module Language.Haskell.Brittany.Internal.Layouters.Expr - ( layoutExpr - , litBriDoc - , overLitValBriDoc - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - -import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name -import qualified FastString -import BasicTypes - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type - - - -layoutExpr :: ToBriDoc HsExpr -layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack - let allowFreeIndent = indentPolicy == IndentPolicyFree - docWrapNode lexpr $ case expr of - HsVar _ vname -> do - docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ var -> case var of - OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname - TrueExprHole oname -> docLit $ Text.pack $ occNameString oname - HsRecFld{} -> do - -- TODO - briDocByExactInlineOnly "HsRecFld" lexpr - HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '#' : label - HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '?' : label - HsOverLit _ olit -> do - allocateNode $ overLitValBriDoc $ ol_val olit - HsLit _ lit -> do - allocateNode $ litBriDoc lit - HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds {} <- llocals - , L _ (GRHS _ [] body) <- lgrhs - -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let shouldPrefixSeparator = case p of - (ghcDL -> L _ LazyPat{}) -> isFirst - (ghcDL -> L _ BangPat{}) -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let funcPatternPartLine = - docCols ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing - $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> - unknownNodeError "HsLam too complex" lexpr - HsLamCase _ XMatchGroup{} -> - error "brittany internal error: HsLamCase XMatchGroup" - HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing $ docAddBaseY BrIndentRegular $ - (docLit $ Text.pack "\\case {}") - HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "\\case") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r:list) l - x -> (x, list) - let (headE, paramEs) = gather [exp2] exp1 - let colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq - headDoc <- docSharedWrapper layoutExpr headE - paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - hasComments <- hasAnyCommentsConnected exp2 - runFilteredAlternative $ do - -- foo x y - addAlternativeCond (not hasComments) - $ colsOrSequence - $ appSep (docForceSingleline headDoc) - : spacifyDocs (docForceSingleline <$> paramDocs) - -- foo x - -- y - addAlternativeCond allowFreeIndent - $ docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ docForceSingleline <$> paramDocs - ] - -- foo - -- x - -- y - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline headDoc) - ( docNonBottomSpacing - $ docLines paramDocs - ) - -- ( multi - -- line - -- function - -- ) - -- x - -- y - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - headDoc - ( docNonBottomSpacing - $ docLines paramDocs - ) - HsApp _ exp1 exp2 -> do - -- TODO: if expDoc1 is some literal, we may want to create a docCols here. - expDoc1 <- docSharedWrapper layoutExpr exp1 - expDoc2 <- docSharedWrapper layoutExpr exp2 - docAlt - [ -- func arg - docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] - , -- func argline1 - -- arglines - -- e.g. - -- func Abc - -- { member1 = True - -- , member2 = 13 - -- } - docSetParSpacing -- this is most likely superfluous because - -- this is a sequence of a one-line and a par-space - -- anyways, so it is _always_ par-spaced. - $ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docForceSingleline expDoc1 - , docForceParSpacing expDoc2 - ] - , -- func - -- arg - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline expDoc1) - (docNonBottomSpacing expDoc2) - , -- fu - -- nc - -- ar - -- gument - docAddBaseY BrIndentRegular - $ docPar - expDoc1 - expDoc2 - ] -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ - HsAppType _ _ XHsWildCardBndrs{} -> - error "brittany internal error: HsAppType XHsWildCardBndrs" - HsAppType _ exp1 (HsWC _ ty1) -> do -#else - HsAppType XHsWildCardBndrs{} _ -> - error "brittany internal error: HsAppType XHsWildCardBndrs" - HsAppType (HsWC _ ty1) exp1 -> do -#endif - t <- docSharedWrapper layoutType ty1 - e <- docSharedWrapper layoutExpr exp1 - docAlt - [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar - e - (docSeq [docLit $ Text.pack "@", t ]) - ] - OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft - leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight - allowSinglelinePar <- do - hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp - pure $ not hasComLeft && not hasComOp - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - runFilteredAlternative $ do - -- > one + two + three - -- or - -- > one + two + case x of - -- > _ -> three - addAlternativeCond allowSinglelinePar - $ docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - -- this case rather leads to some unfortunate layouting than to anything - -- useful; disabling for now. (it interfers with cols stuff.) - -- addAlternative - -- $ docSetBaseY - -- $ docPar - -- leftOperandDoc - -- ( docLines - -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - -- ) - -- > one - -- > + two - -- > + three - addAlternative $ - docPar - leftOperandDoc - ( docLines - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - ) - OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp - expDocRight <- docSharedWrapper layoutExpr expRight - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False - runFilteredAlternative $ do - -- one-line - addAlternative - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceSingleline expDocRight - ] - -- -- line + freely indented block for right expression - -- addAlternative - -- $ docSeq - -- [ appSep $ docForceSingleline expDocLeft - -- , appSep $ docForceSingleline expDocOp - -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight - -- ] - -- two-line - addAlternative $ do - let - expDocOpAndRight = docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight - -- TODO: in both cases, we don't force expDocLeft to be - -- single-line, which has certain.. interesting consequences. - -- At least, the "two-line" label is not entirely - -- accurate. - -- one-line + par - addAlternativeCond allowPar - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceParSpacing expDocRight - ] - -- more lines - addAlternative $ do - let expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight - NegApp _ op _ -> do - opDoc <- docSharedWrapper layoutExpr op - docSeq [ docLit $ Text.pack "-" - , opDoc - ] - HsPar _ innerExp -> do - innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp - docAlt - [ docSeq - [ docLit $ Text.pack "(" - , docForceSingleline innerExpDoc - , docLit $ Text.pack ")" - ] - , docSetBaseY $ docLines - [ docCols ColOpPrefix - [ docLit $ Text.pack "(" - , docAddBaseY (BrIndentSpecial 2) innerExpDoc - ] - , docLit $ Text.pack ")" - ] - ] - SectionL _ left op -> do -- TODO: add to testsuite - leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op - docSeq [leftDoc, docSeparator, opDoc] - SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op - rightDoc <- docSharedWrapper layoutExpr right - docSeq [opDoc, docSeparator, rightDoc] - ExplicitTuple _ args boxity -> do -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e); - (L _ (Missing NoExtField)) -> (arg, Nothing) - (L _ XTupArg{}) -> error "brittany internal error: XTupArg" -#else - let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e); - (L _ (Missing NoExt)) -> (arg, Nothing) - (L _ XTupArg{}) -> error "brittany internal error: XTupArg" -#endif - argDocs <- forM argExprs - $ docSharedWrapper - $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- orM - ( hasCommentsBetween lexpr AnnOpenP AnnCloseP - : map hasAnyCommentsBelow args - ) - let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) - case splitFirstLast argDocs of - FirstLastEmpty -> docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) closeLit - ] - FirstLastSingleton e -> docAlt - [ docCols ColTuple - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - , closeLit - ] - , docSetBaseY $ docLines - [ docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - ] - , closeLit - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] - ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] - addAlternative $ - let - start = docCols ColTuples - [appSep openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] - HsCase _ _ XMatchGroup{} -> - error "brittany internal error: HsCase XMatchGroup" - HsCase _ cExp (MG _ (L _ []) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - docAlt - [ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] - , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") - ] - HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches - docAlt - [ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of" - ]) - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "of") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - ) - ] - HsIf _ _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr - thenExprDoc <- docSharedWrapper layoutExpr thenExpr - elseExprDoc <- docSharedWrapper layoutExpr elseExpr - hasComments <- hasAnyCommentsBelow lexpr - let maySpecialIndent = - case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 - -- TODO: some of the alternatives (especially last and last-but-one) - -- overlap. - docSetIndentLevel $ runFilteredAlternative $ do - -- if _ then _ else _ - addAlternativeCond (not hasComments) - $ docSeq - [ appSep $ docLit $ Text.pack "if" - , appSep $ docForceSingleline ifExprDoc - , appSep $ docLit $ Text.pack "then" - , appSep $ docForceSingleline thenExprDoc - , appSep $ docLit $ Text.pack "else" - , docForceSingleline elseExprDoc - ] - -- either - -- if expr - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if expr - -- then - -- stuff - -- else - -- stuff - -- note that this has par-spacing - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - -- either - -- if multi - -- line - -- condition - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if multi - -- line - -- condition - -- then - -- stuff - -- else - -- stuff - -- note that this does _not_ have par-spacing - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - addAlternative - $ docSetBaseY - $ docLines - [ docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" - hasComments <- hasAnyCommentsBelow lexpr - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "if") - (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) - HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 - -- We jump through some ugly hoops here to ensure proper sharing. - hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap (fmap pure)) $ layoutLocalBinds binds - let - ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = - case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x - -- this `docSetBaseAndIndent` might seem out of place (especially the - -- Indent part; setBase is necessary due to the use of docLines below), - -- but is here due to ghc-exactprint's DP handling of "let" in - -- particular. - -- Just pushing another indentation level is a straightforward approach - -- to making brittany idempotent, even though the result is non-optimal - -- if "let" is moved horizontally as part of the transformation, as the - -- comments before the first let item are moved horizontally with it. - docSetBaseAndIndent $ case mBindDocs of - Just [bindDoc] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) - $ appSep $ docForceSingleline bindDoc - , appSep $ docLit $ Text.pack "in" - , docForceSingleline expDoc1 - ] - addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) - ] - , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY expDoc1) - ] - ] - Just bindDocs@(_:_) -> runFilteredAlternative $ do - --either - -- let - -- a = b - -- c = d - -- in foo - -- bar - -- baz - --or - -- let - -- a = b - -- c = d - -- in - -- fooooooooooooooooooo - let noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular - $ docForceParSpacing expDoc1 - ] - ] - addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds - IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines bindDocs - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY expDoc1 - ] - ] - addAlternative - $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) - ] - _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] - -- docSeq [appSep $ docLit "let in", expDoc1] - HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of - DoExpr -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - MDoExpr -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ docForceSingleline <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative $ - let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - _ -> do - -- TODO - unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr - hasComments <- hasAnyCommentsBelow lexpr - case splitFirstLast elemDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "[" - , docSeparator - , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e - ] - , docLit $ Text.pack "]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) - ++ [docLit $ Text.pack "]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> - docLit $ Text.pack "[]" - RecordCon _ lname fields -> - case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- fs - `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - HsRecFields [] (Just (L _ 0)) -> do -#else - HsRecFields [] (Just 0) -> do -#endif - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do -#else - HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do -#endif - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr - RecordUpd _ rExpr fields -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- fields - `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ case ambName of - Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - XAmbiguousFieldOcc{} -> - error "brittany internal error: XAmbiguousFieldOcc" - recordExpression False indentPolicy lexpr rExprDoc rFs -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */ - ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) -> - error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" - ExprWithTySig _ _ XHsWildCardBndrs{} -> - error "brittany internal error: ExprWithTySig XHsWildCardBndrs" - ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do -#else - ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ -> - error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" - ExprWithTySig XHsWildCardBndrs{} _ -> - error "brittany internal error: ExprWithTySig XHsWildCardBndrs" - ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do -#endif - expDoc <- docSharedWrapper layoutExpr exp1 - typDoc <- docSharedWrapper layoutType typ1 - docSeq - [ appSep expDoc - , appSep $ docLit $ Text.pack "::" - , typDoc - ] - ArithSeq _ Nothing info -> - case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> - briDocByExactInlineOnly "ArithSeq" lexpr - HsSCC{} -> do - -- TODO - briDocByExactInlineOnly "HsSCC{}" lexpr - HsCoreAnn{} -> do - -- TODO - briDocByExactInlineOnly "HsCoreAnn{}" lexpr - HsBracket{} -> do - -- TODO - briDocByExactInlineOnly "HsBracket{}" lexpr - HsRnBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsRnBracketOut{}" lexpr - HsTcBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsTcBracketOut{}" lexpr - HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do - allocateNode $ BDFPlain - (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]") - HsSpliceE{} -> do - -- TODO - briDocByExactInlineOnly "HsSpliceE{}" lexpr - HsProc{} -> do - -- TODO - briDocByExactInlineOnly "HsProc{}" lexpr - HsStatic{} -> do - -- TODO - briDocByExactInlineOnly "HsStatic{}" lexpr -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -#else - HsArrApp{} -> do - -- TODO - briDocByExactInlineOnly "HsArrApp{}" lexpr - HsArrForm{} -> do - -- TODO - briDocByExactInlineOnly "HsArrForm{}" lexpr -#endif - HsTick{} -> do - -- TODO - briDocByExactInlineOnly "HsTick{}" lexpr - HsBinTick{} -> do - -- TODO - briDocByExactInlineOnly "HsBinTick{}" lexpr - HsTickPragma{} -> do - -- TODO - briDocByExactInlineOnly "HsTickPragma{}" lexpr -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -#else - EWildPat{} -> do - docLit $ Text.pack "_" - EAsPat _ asName asExpr -> do - docSeq - [ docLit $ lrdrNameToText asName <> Text.pack "@" - , layoutExpr asExpr - ] - EViewPat{} -> do - -- TODO - briDocByExactInlineOnly "EViewPat{}" lexpr - ELazyPat{} -> do - -- TODO - briDocByExactInlineOnly "ELazyPat{}" lexpr -#endif - HsWrap{} -> do - -- TODO - briDocByExactInlineOnly "HsWrap{}" lexpr - HsConLikeOut{} -> do - -- TODO - briDocByExactInlineOnly "HsWrap{}" lexpr - ExplicitSum{} -> do - -- TODO - briDocByExactInlineOnly "ExplicitSum{}" lexpr - XExpr{} -> error "brittany internal error: XExpr" - -recordExpression - :: (Data.Data.Data lExpr, Data.Data.Data name) - => Bool - -> IndentPolicy - -> GenLocated SrcSpan lExpr - -> ToBriDocM BriDocNumbered - -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] - -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = - docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = - docSeq -- this case might still be incomplete, and is probably not used - -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do - let (rF1f, rF1n, rF1e) = rF1 - runFilteredAlternative $ do - -- container { fieldA = blub, fieldB = blub } - addAlternative - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc - , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr - , if dotdot - then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator - , docLit $ Text.pack "}" - ] - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docSeq - [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ] - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield - $ docCols ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq [ appSep $ docLit $ Text.pack "=" - , docForceParSpacing x - ] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) - -litBriDoc :: HsLit GhcPs -> BriDocFInt -litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - _ -> error "litBriDoc: literal with no SourceText" - -overLitValBriDoc :: OverLitVal -> BriDocFInt -overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsIsString (SourceText t) _ -> BDFLit $ Text.pack t - _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Internal.Layouters.Expr - ( layoutExpr - , litBriDoc - , overLitValBriDoc - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import GHC ( runGhc, GenLocated(L), moduleNameString ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name - - - -layoutExpr :: ToBriDoc HsExpr - --- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) - -litBriDoc :: HsLit GhcPs -> BriDocFInt - -overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ /dev/null @@ -1,228 +0,0 @@ -module Language.Haskell.Brittany.Internal.Layouters.IE - ( layoutIE - , layoutLLIEs - , layoutAnnAndSepLLIEs - , SortItemsFlag(..) - ) -where - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( unLoc - , runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - , Located - , ModuleName - ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -import GHC.Hs.ImpExp -#else -import HsSyn -import HsImpExp -#endif -import Name -import FieldLabel -import qualified FastString -import BasicTypes - -import Language.Haskell.Brittany.Internal.Utils - - - -prepareName :: LIEWrappedName name -> Located name -prepareName = ieLWrappedName - -layoutIE :: ToBriDoc IE -layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of - IEVar _ x -> layoutWrapped lie x - IEThingAbs _ x -> layoutWrapped lie x - IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x (IEWildcard _) _ _ -> - docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x _ ns _ -> do - hasComments <- orM - ( hasCommentsBetween lie AnnOpenP AnnCloseP - : hasAnyCommentsBelow x - : map hasAnyCommentsBelow ns - ) - let sortedNs = List.sortOn wrappedNameToText ns - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc sortedNs) - ++ [docParenR] - addAlternative - $ docWrapNodeRest lie - $ docAddBaseY BrIndentRegular - $ docPar - (layoutWrapped lie x) - (layoutItems (splitFirstLast sortedNs)) - where - nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName - layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] - layoutItems FirstLastEmpty = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] - layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] - layoutItems (FirstLast n1 nMs nN) = - docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] - ++ map layoutItem nMs - ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] - IEModuleContents _ n -> docSeq - [ docLit $ Text.pack "module" - , docSeparator - , docLit . Text.pack . moduleNameString $ unLoc n - ] - _ -> docEmpty - where - layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n - L _ (IEPattern n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "pattern " <> name - L _ (IEType n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "type " <> name - -data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted --- Helper function to deal with Located lists of LIEs. --- In particular this will also associate documentation --- from the located list that actually belongs to the last IE. --- It also adds docCommaSep to all but the first element --- This configuration allows both vertical and horizontal --- handling of the resulting list. Adding parens is --- left to the caller since that is context sensitive -layoutAnnAndSepLLIEs - :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] -layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do - let makeIENode ie = docSeq [docCommaSep, ie] - let sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText - $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies - ieCommaDocs <- - docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] - FirstLastSingleton ie -> [ie] - FirstLast ie1 ieMs ieN -> - [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] - pure $ fmap pure ieCommaDocs -- returned shared nodes - where - mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] - mergeGroup items@[_] = items - mergeGroup items = if - | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items - -- proper means that if it is a ThingWith, it does not contain a wildcard - -- (because I don't know what a wildcard means if it is not already a - -- IEThingAll). - isProperIEThing :: LIE GhcPs -> Bool - isProperIEThing = \case - L _ (IEThingAbs _ _wn) -> True - L _ (IEThingAll _ _wn) -> True - L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True - _ -> False - isIEVar :: LIE GhcPs -> Bool - isIEVar = \case - L _ IEVar{} -> True - _ -> False - thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{} ) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 ( L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 - thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) - = L - l - (IEThingWith x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) - ) - thingFolder _ _ = - error "thingFolder should be exhaustive because we have a guard above" - - --- Builds a complete layout for the given located --- list of LIEs. The layout provides two alternatives: --- (item, item, ..., item) --- ( item --- , item --- ... --- , item --- ) --- If the llies contains comments the list will --- always expand over multiple lines, even when empty: --- () -- no comments --- ( -- a comment --- ) -layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered -layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies - hasComments <- hasAnyCommentsBelow llies - runFilteredAlternative $ case ieDs of - [] -> do - addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" - addAlternativeCond hasComments $ docPar - (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH : ieDsT) -> do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] - --- | Returns a "fingerprint string", not a full text representation, nor even --- a source code representation of this syntax node. --- Used for sorting, not for printing the formatter's output source code. -wrappedNameToText :: LIEWrappedName RdrName -> Text -wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n - L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n - --- | Returns a "fingerprint string", not a full text representation, nor even --- a source code representation of this syntax node. --- Used for sorting, not for printing the formatter's output source code. -lieToText :: LIE GhcPs -> Text -lieToText = \case - L _ (IEVar _ wn ) -> wrappedNameToText wn - L _ (IEThingAbs _ wn ) -> wrappedNameToText wn - L _ (IEThingAll _ wn ) -> wrappedNameToText wn - L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn - -- TODO: These _may_ appear in exports! - -- Need to check, and either put them at the top (for module) or do some - -- other clever thing. - L _ (IEModuleContents _ n) -> moduleNameToText n - L _ (IEGroup _ _ _ ) -> Text.pack "@IEGroup" - L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" - L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" - L _ (XIE _ ) -> Text.pack "@XIE" - where - moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ /dev/null @@ -1,160 +0,0 @@ -module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( unLoc - , GenLocated(L) - , moduleNameString - , Located - ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name -import FieldLabel -import qualified FastString -import BasicTypes -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - -import Language.Haskell.Brittany.Internal.Utils - - - -prepPkg :: SourceText -> String -prepPkg rawN = case rawN of - SourceText n -> n - -- This would be odd to encounter and the - -- result will most certainly be wrong - NoSourceText -> "" -prepModName :: Located e -> e -prepModName = unLoc - -layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered -layoutImport importD = case importD of - ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do - importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let - compact = indentPolicy /= IndentPolicyFree - modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies - minQLength = length "import qualified " - qLengthReal = -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - let qualifiedPart = if q /= NotQualified then length "qualified " else 0 -#else - let qualifiedPart = if q then length "qualified " else 0 -#endif - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = if src then length "{-# SOURCE #-} " else 0 - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal - -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength - importQualifiers = docSeq - [ appSep $ docLit $ Text.pack "import" - , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty - , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty -#else - , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty -#endif - , maybe docEmpty (appSep . docLit) pkgNameT - ] - indentName = - if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = - indentName $ appSep $ docLit modNameT - hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 - hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = if hiding - then appSep $ docLit $ Text.pack "hiding" - else docEmpty - importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of - Nothing -> docEmpty - Just (_, llies) -> do - hasComments <- hasAnyCommentsBelow llies - if compact - then docAlt - [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] - , let makeParIfHiding = if hiding - then docAddBaseY BrIndentRegular . docPar hidDoc - else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar - (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - ( docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) - makeAsDoc asT = - docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] - if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular $ - docPar (docSeq [importHead, asDoc]) bindingsD - ] - else - case masT of - Just n -> if enoughRoom - then docLines - [ docSeq [importHead, asDoc], bindingsD] - else docLines [importHead, asDoc, bindingsD] - where - enoughRoom = nameCost < importAsCol - asCost - asDoc = - docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n - Nothing -> if enoughRoom - then docSeq [importHead, bindingsD] - else docLines [importHead, bindingsD] - where enoughRoom = nameCost < importCol - hidingParenCost - _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -import GHC.Hs.ImpExp -#else -import HsSyn -import HsImpExp -#endif -import Name -import FieldLabel -import qualified FastString -import BasicTypes -import Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types - ( DeltaPos(..) - , deltaRow - , commentContents - ) - -import Language.Haskell.Brittany.Internal.Utils - - - -layoutModule :: ToBriDoc HsModule -layoutModule lmod@(L _ mod') = case mod' of - -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> do - commentedImports <- transformToCommentedImport imports - -- groupify commentedImports `forM_` tellDebugMessShow - docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) - -- sortedImports <- sortImports imports - -- docLines $ [layoutImport y i | (y, i) <- sortedImports] - HsModule (Just n) les imports _ _ _ -> do - commentedImports <- transformToCommentedImport imports - -- groupify commentedImports `forM_` tellDebugMessShow - -- sortedImports <- sortImports imports - let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- mAsk - <&> _conf_layout - .> _lconfig_allowSingleLineExportList - .> confUnpack - -- the config should not prevent single-line layout when there is no - -- export list - let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les - docLines - $ docSeq - [ docNodeAnnKW lmod Nothing docEmpty - -- A pseudo node that serves merely to force documentation - -- before the node - , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ - docForceSingleline - $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative - $ docLines - [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docSeq [ - docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) - ] - ] - : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] - -data CommentedImport - = EmptyLine - | IndependentComment (Comment, DeltaPos) - | ImportStatement ImportStatementRecord - -instance Show CommentedImport where - show = \case - EmptyLine -> "EmptyLine" - IndependentComment _ -> "IndependentComment" - ImportStatement r -> - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -data ImportStatementRecord = ImportStatementRecord - { commentsBefore :: [(Comment, DeltaPos)] - , commentsAfter :: [(Comment, DeltaPos)] - , importStatement :: ImportDecl GhcPs - } - -instance Show ImportStatementRecord where - show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -transformToCommentedImport - :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] -transformToCommentedImport is = do - nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do - annotionMay <- astAnn i - pure (annotionMay, rawImport) - let - convertComment (c, DP (y, x)) = - replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] - accumF - :: [(Comment, DeltaPos)] - -> (Maybe Annotation, ImportDecl GhcPs) - -> ([(Comment, DeltaPos)], [CommentedImport]) - accumF accConnectedComm (annMay, decl) = case annMay of - Nothing -> - ( [] - , [ ImportStatement ImportStatementRecord { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } - ] - ) - Just ann -> - let - blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 - (newAccumulator, priorComments') = - List.span ((== 0) . deltaRow . snd) (annPriorComments ann) - go - :: [(Comment, DeltaPos)] - -> [(Comment, DeltaPos)] - -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) - go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) - go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs - go acc ((c1, DP (y, x)) : xs) = - ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine - , (c1, DP (1, x)) : acc - , 0 - ) - (convertedIndependentComments, beforeComments, initialBlanks) = - if blanksBeforeImportDecl /= 0 - then (convertComment =<< priorComments', [], 0) - else go [] (reverse priorComments') - in - ( newAccumulator - , convertedIndependentComments - ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine - ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm - , importStatement = decl - } - ] - ) - let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations - pure $ join $ (convertComment =<< finalAcc) : finalList - -sortCommentedImports :: [CommentedImport] -> [CommentedImport] -sortCommentedImports = - unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify - where - unpackImports :: [CommentedImport] -> [CommentedImport] - unpackImports xs = xs >>= \case - l@EmptyLine -> [l] - l@IndependentComment{} -> [l] - ImportStatement r -> - map IndependentComment (commentsBefore r) ++ [ImportStatement r] - mergeGroups - :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] - mergeGroups xs = xs >>= \case - Left x -> [x] - Right y -> ImportStatement <$> y - sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] - sortGroups = - List.sortOn (moduleNameString . unLoc . ideclName . importStatement) - groupify - :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] - groupify cs = go [] cs - where - go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest - (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] - go acc = \case - (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest - (l@IndependentComment{} : rest) -> - Left l : Right (reverse acc) : go [] rest - (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] - -commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered -commentedImportsToDoc = \case - EmptyLine -> docLitS "" - IndependentComment c -> commentToDoc c - ImportStatement r -> - docSeq - ( layoutImport (importStatement r) - : map commentToDoc (commentsAfter r) - ) - where - commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} - -module Language.Haskell.Brittany.Internal.Layouters.Pattern - ( layoutPat - , colsWrapPat - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import GHC ( Located - , runGhc - , GenLocated(L) - , moduleNameString - , ol_val - ) -import qualified GHC -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name -import BasicTypes - -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type - - - --- | layouts patterns (inside function bindings, case alternatives, let --- bindings or do notation). E.g. for input --- > case computation of --- > (warnings, Success a b) -> .. --- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by --- 'layoutPat'. Similarly for --- > func abc True 0 = [] --- ^^^^^^^^^^ this part --- We will use `case .. of` as the imagined prefix to the examples used in --- the different cases below. -layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) -layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" - -- _ -> expr - VarPat _ n -> - fmap Seq.singleton $ docLit $ lrdrNameToText n - -- abc -> expr - LitPat _ lit -> - fmap Seq.singleton $ allocateNode $ litBriDoc lit - -- 0 -> expr -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ - ParPat _ inner -> do -#else - ParPat _ inner -> do -#endif - -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" - right <- docLit $ Text.pack ")" - innerDocs <- colsWrapPat =<< layoutPat inner - return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right - -- return $ (left Seq.<| innerDocs) Seq.|> right - -- case Seq.viewl innerDocs of - -- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur.. - -- x1 Seq.:< rest -> case Seq.viewr rest of - -- Seq.EmptyR -> - -- fmap return $ docSeq - -- [ docLit $ Text.pack "(" - -- , return x1 - -- , docLit $ Text.pack ")" - -- ] - -- middle Seq.:> xN -> do - -- x1' <- docSeq [docLit $ Text.pack "(", return x1] - -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] - -- return $ (x1' Seq.<| middle) Seq.|> xN' - ConPatIn lname (PrefixCon args) -> do - -- Abc a b c -> expr - nameDoc <- lrdrNameToTextAnn lname - argDocs <- layoutPat `mapM` args - if null argDocs - then return <$> docLit nameDoc - else do - x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList - $ sequence - $ spacifyDocs - $ fmap colsWrapPat argDocs - return $ x1 Seq.<| xR - ConPatIn lname (InfixCon left right) -> do - -- a :< b -> expr - nameDoc <- lrdrNameToTextAnn lname - leftDoc <- appSep . colsWrapPat =<< layoutPat left - rightDoc <- colsWrapPat =<< layoutPat right - middle <- appSep $ docLit nameDoc - return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc - ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do - -- Abc{} -> expr - let t = lrdrNameToText lname - fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do - -- Abc { a = locA, b = locB, c = locC } -> expr1 - -- Abc { a, b, c } -> expr2 - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName - , docSeparator - , docLit $ Text.pack "}" - ] -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - ConPatIn lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -#else - ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do -#endif - -- Abc { .. } -> expr - let t = lrdrNameToText lname - Seq.singleton <$> docSeq - [ appSep $ docLit t - , docLit $ Text.pack "{..}" - ] -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do -#else - ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do -#endif - -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case - (fieldName, Just fieldDoc) -> - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - , docCommaSep - ] - (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] - TuplePat _ args boxity -> do - -- (nestedpat1, nestedpat2, nestedpat3) -> expr - -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr - case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR - Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep - AsPat _ asName asPat -> do - -- bind@nestedpat -> expr - wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ - SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do -#else - SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do -#endif - -- i :: Int -> expr - patDocs <- layoutPat pat1 - tyDoc <- docSharedWrapper layoutType ty1 - case Seq.viewr patDocs of - Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" - xR Seq.:> xN -> do - xN' <- -- at the moment, we don't support splitting patterns into - -- multiple lines. but we cannot enforce pasting everything - -- into one line either, because the type signature will ignore - -- this if we overflow sufficiently. - -- In order to prevent syntactically invalid results in such - -- cases, we need the AddBaseY here. - -- This can all change when patterns get multiline support. - docAddBaseY BrIndentRegular $ docSeq - [ appSep $ return xN - , appSep $ docLit $ Text.pack "::" - , docForceSingleline tyDoc - ] - return $ xR Seq.|> xN' - ListPat _ elems -> - -- [] -> expr1 - -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 - wrapPatListy elems "[]" docBracketL docBracketR - BangPat _ pat1 -> do - -- !nestedpat -> expr - wrapPatPrepend pat1 (docLit $ Text.pack "!") - LazyPat _ pat1 -> do - -- ~nestedpat -> expr - wrapPatPrepend pat1 (docLit $ Text.pack "~") - NPat _ llit@(L _ ol) mNegative _ -> do - -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol - negDoc <- docLit $ Text.pack "-" - pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] - Nothing -> Seq.singleton litDoc - - _ -> return <$> briDocByExactInlineOnly "some unknown pattern" (ghcDL lpat) - -colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered -colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList - -wrapPatPrepend - :: LPat GhcPs - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR - -wrapPatListy - :: [LPat GhcPs] - -> String - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) -wrapPatListy elems both start end = do - elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) - case Seq.viewl elemDocs of - Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both - x1 Seq.:< rest -> do - sDoc <- start - eDoc <- end - rest' <- rest `forM` \bd -> docSeq - [ docCommaSep - , return bd - ] - return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Internal.Layouters.Stmt - ( layoutStmt - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( runGhc - , GenLocated(L) - , moduleNameString - ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name -import qualified FastString -import BasicTypes - -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Decl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr - - - -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) -layoutStmt lstmt@(L _ stmt) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - indentAmount :: Int <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - docWrapNode lstmt $ case stmt of - LastStmt _ body False _ -> do - layoutExpr body - BindStmt _ lPat expr _ _ -> do - patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docAlt - [ docCols - ColBindStmt - [ appSep patDoc - , docSeq - [ appSep $ docLit $ Text.pack "<-" - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc - ] - ] - , docCols - ColBindStmt - [ appSep patDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "<-") (expDoc) - ] - ] - LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree - let indentFourPlus = indentAmount >= 4 - layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" - -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAlt - [ -- let bind = expr - docCols - ColDoLet - [ appSep $ docLit $ Text.pack "let" - , let - f = case indentPolicy of - IndentPolicyFree -> docSetBaseAndIndent - IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc - ] - , -- let - -- bind = expr - docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - ] - Just bindDocs -> runFilteredAlternative $ do - -- let aaa = expra - -- bbb = exprb - -- ccc = exprc - addAlternativeCond (isFree || indentFourPlus) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , let f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs - ] - -- let - -- aaa = expra - -- bbb = exprb - -- ccc = exprc - addAlternativeCond (not indentFourPlus) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do - -- rec stmt1 - -- stmt2 - -- stmt3 - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] - -- rec - -- stmt1 - -- stmt2 - -- stmt3 - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docLit (Text.pack "rec")) - (docLines $ layoutStmt <$> stmts) - BodyStmt _ expr _ _ -> do - expDoc <- docSharedWrapper layoutExpr expr - docAddBaseY BrIndentRegular $ expDoc - _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Internal.Layouters.Stmt - ( layoutStmt - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import GHC ( runGhc, GenLocated(L), moduleNameString ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name -import qualified FastString -import BasicTypes - - - -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ /dev/null @@ -1,665 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Internal.Layouters.Type - ( layoutType - , layoutTyVarBndrs - , processTyVarBndrsSingleline - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Utils - ( splitFirstLast - , FirstLastView(..) - ) - -import GHC ( runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId (..) - ) -import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs -#else -import HsSyn -#endif -import Name -import Outputable ( ftext, showSDocUnsafe ) -import BasicTypes -import qualified SrcLoc - -import DataTreePrint - - - -layoutType :: ToBriDoc HsType -layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of - -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" - HsTyVar _ promoted name -> do - t <- lrdrNameToTextAnnTypeEqualityIsSpecial name - case promoted of -#if MIN_VERSION_ghc(8,8,0) - IsPromoted -> docSeq -#else /* ghc-8.6 */ - Promoted -> docSeq -#endif - [ docSeparator - , docTick - , docWrapNode name $ docLit t - ] - NotPromoted -> docWrapNode name $ docLit t -#if MIN_VERSION_ghc(8,10,1) - HsForAllTy _ _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do -#else - HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do -#endif - typeDoc <- docSharedWrapper layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let - tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - forallDoc = docAlt - [ let - open = docLit $ Text.pack "forall" - in docSeq ([open]++tyVarDocLineList) - , docPar - (docLit (Text.pack "forall")) - (docLines - $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ]) - ] - contextDoc = case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) - , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) cntxtDoc - ] - in docPar open $ docLines $ list ++ [close] - ] - docAlt - -- :: forall a b c . (Foo a b c) => a b -> c - [ docSeq - [ if null bndrs - then docEmpty - else let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) - , docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- :: forall a b c - -- . (Foo a b c) - -- => a b - -- -> c - , docPar - forallDoc - ( docLines - [ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) - $ contextDoc - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] - ] - ) - ] -#if MIN_VERSION_ghc(8,10,1) - HsForAllTy _ _ bndrs typ2 -> do -#else - HsForAllTy _ bndrs typ2 -> do -#endif - typeDoc <- layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - docAlt - -- forall x . x - [ docSeq - [ if null bndrs - then docEmpty - else let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open]++tyVarDocLineList++[close]) - , docForceSingleline $ return $ typeDoc - ] - -- :: forall x - -- . x - , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) - -- :: forall - -- (x :: *) - -- . x - , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ] - ) - ++[ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ] - ) - ] - HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do - typeDoc <- docSharedWrapper layoutType typ1 - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - contextDoc = docWrapNode lcntxts $ case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) - , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) - $ head cntxtDocs - ] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) - $ cntxtDoc - ] - in docPar open $ docLines $ list ++ [close] - ] - let maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - docAlt - -- (Foo a b c) => a b -> c - [ docSeq - [ docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- (Foo a b c) - -- => a b - -- -> c - , docPar - (docForceSingleline contextDoc) - ( docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) - ] - HsFunTy _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - hasComments <- hasAnyCommentsBelow ltype - docAlt $ - [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 - ] - | not hasComments - ] ++ - [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) - $ maybeForceML typeDoc2 - ] - ) - ] - HsParTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docLit $ Text.pack ")" - ] - , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack ")") - ] - HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 - final -> (final, list) - let (typHead, typRest) = gather [typ2] typ1 - docHead <- docSharedWrapper layoutType typHead - docRest <- docSharedWrapper layoutType `mapM` typRest - docAlt - [ docSeq - $ docForceSingleline docHead : (docRest >>= \d -> - [ docSeparator, docForceSingleline d ]) - , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) - ] - HsAppTy _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - docAlt - [ docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docForceSingleline typeDoc2 - ] - , docPar - typeDoc1 - (docEnsureIndent BrIndentRegular typeDoc2) - ] - HsListTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "[" - , docForceSingleline typeDoc1 - , docLit $ Text.pack "]" - ] - , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack "]") - ] - HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple - HsBoxedOrConstraintTuple -> simple - where - unboxed = if null typs then error "brittany internal error: unboxed unit" - else unboxedL - simple = if null typs then unitL else simpleL - unitL = docLit $ Text.pack "()" - simpleL = do - docs <- docSharedWrapper layoutType `mapM` typs - let end = docLit $ Text.pack ")" - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) - docAlt - [ docSeq $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] - , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) - ] - unboxedL = do - docs <- docSharedWrapper layoutType `mapM` typs - let start = docParenHashLSep - end = docParenHashRSep - docAlt - [ docSeq $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] - , let - line1 = docCols ColTyOpPrefix [start, head docs] - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - in docPar - (docAddBaseY (BrIndentSpecial 2) line1) - (docLines $ lines ++ [end]) - ] - HsOpTy{} -> -- TODO - briDocByExactInlineOnly "HsOpTy{}" ltype - -- HsOpTy typ1 opName typ2 -> do - -- -- TODO: these need some proper fixing. precedences don't add up. - -- -- maybe the parser just returns some trivial right recursion - -- -- parse result for any type level operators. - -- -- need to check how things are handled on the expression level. - -- let opStr = lrdrNameToText opName - -- let opLen = Text.length opStr - -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 - -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 - -- let line = do -- Maybe - -- l1 <- _ldesc_line desc1 - -- l2 <- _ldesc_line desc2 - -- let len1 = _lColumns_min l1 - -- let len2 = _lColumns_min l2 - -- let len = 2 + opLen + len1 + len2 - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol1 <- descToBlockStart desc1 - -- (min2, max2) <- descToMinMax (1+opLen) desc2 - -- let (minR, maxR) = case descToBlockMinMax desc1 of - -- Nothing -> (min2, max2) - -- Just (min1, max1) -> (max min1 min2, max max1 max2) - -- return $ BlockDesc - -- { _bdesc_blockStart = rol1 - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Just (1+opLen) - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \params -> do - -- remaining <- getCurRemaining - -- let allowSameLine = _params_sepLines params /= SepLineTypeOp - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do - -- applyLayouterRestore layouter1 defaultParams - -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " - -- applyLayouterRestore layouter2 defaultParams - -- _ -> do - -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params - -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 - -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams - -- layoutWriteNewline - -- layoutWriteAppend $ opStr <> Text.pack " " - -- layoutWriteEnsureBlockPlusN downIndent - -- applyLayouterRestore layouter2 defaultParams - -- { _params_sepLines = SepLineTypeOp - -- , _params_opIndent = Just downIndent - -- } - -- , _layouter_ast = ltype - -- } - HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype - $ docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") - , docForceSingleline typeDoc1 - ] - , docPar - ( docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) - ) - (docCols ColTyOpPrefix - [ docWrapNodeRest ltype - $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ]) - ] - -- TODO: test KindSig - HsKindSig _ typ1 kind1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - kindDoc1 <- docSharedWrapper layoutType kind1 - hasParens <- hasAnnKeyword ltype AnnOpenP - docAlt - [ if hasParens - then docSeq - [ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - , docLit $ Text.pack ")" - ] - else docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - ] - , if hasParens - then docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 3) $ typeDoc1 - ] - , docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - , (docLit $ Text.pack ")") - ] - else docPar - typeDoc1 - ( docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - ) - ] - HsBangTy{} -> -- TODO - briDocByExactInlineOnly "HsBangTy{}" ltype - -- HsBangTy bang typ1 -> do - -- let bangStr = case bang of - -- HsSrcBang _ unpackness strictness -> - -- (++) - -- (case unpackness of - -- SrcUnpack -> "{-# UNPACK -#} " - -- SrcNoUnpack -> "{-# NOUNPACK -#} " - -- NoSrcUnpack -> "" - -- ) - -- (case strictness of - -- SrcLazy -> "~" - -- SrcStrict -> "!" - -- NoSrcStrict -> "" - -- ) - -- let bangLen = length bangStr - -- layouter@(Layouter desc _ _) <- layoutType typ1 - -- let line = do -- Maybe - -- l <- _ldesc_line desc - -- let len = bangLen + _lColumns_min l - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol <- descToBlockStart desc - -- (minR,maxR) <- descToBlockMinMax desc - -- return $ BlockDesc - -- { _bdesc_blockStart = rol - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Nothing - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \_params -> do - -- remaining <- getCurRemaining - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- applyLayouterRestore layouter defaultParams - -- _ -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- layoutWritePostCommentsRestore ltype - -- applyLayouterRestore layouter defaultParams - -- , _layouter_ast = ltype - -- } - HsSpliceTy{} -> -- TODO - briDocByExactInlineOnly "HsSpliceTy{}" ltype - HsDocTy{} -> -- TODO - briDocByExactInlineOnly "HsDocTy{}" ltype - HsRecTy{} -> -- TODO - briDocByExactInlineOnly "HsRecTy{}" ltype - HsExplicitListTy _ _ typs -> do - typDocs <- docSharedWrapper layoutType `mapM` typs - hasComments <- hasAnyCommentsBelow ltype - let specialCommaSep = appSep $ docLit $ Text.pack " ," - docAlt - [ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) - ++ [docLit $ Text.pack "]"] - , case splitFirstLast typDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "'[" - , docSeparator - , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e - ] - , docLit $ Text.pack " ]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) - ++ [docLit $ Text.pack " ]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> - docCols ColList [specialCommaSep, d] - lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] - HsExplicitTupleTy{} -> -- TODO - briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype - HsTyLit _ lit -> case lit of - HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsNumTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsStrTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> - docLit $ Text.pack "_" - HsSumTy{} -> -- TODO - briDocByExactInlineOnly "HsSumTy{}" ltype - HsStarTy _ isUnicode -> do - if isUnicode - then docLit $ Text.pack "\x2605" -- Unicode star - else docLit $ Text.pack "*" - XHsType{} -> error "brittany internal error: XHsType" -#if MIN_VERSION_ghc(8,8,0) - HsAppKindTy _ ty kind -> do - t <- docSharedWrapper layoutType ty - k <- docSharedWrapper layoutType kind - docAlt - [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar - t - (docSeq [docLit $ Text.pack "@", k ]) - ] -#endif - -layoutTyVarBndrs - :: [LHsTyVarBndr GhcPs] - -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] -layoutTyVarBndrs = mapM $ \case - (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar _ lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" - --- there is no specific reason this returns a list instead of a single --- BriDoc node. -processTyVarBndrsSingleline - :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] -processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case - (tname, Nothing) -> [docSeparator, docLit tname] - (tname, Just doc) -> - [ docSeparator - , docLit $ Text.pack "(" <> tname <> Text.pack " :: " - , docForceSingleline $ doc - , docLit $ Text.pack ")" - ] diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ /dev/null @@ -1,100 +0,0 @@ -module Language.Haskell.Brittany.Internal.Obfuscation - ( obfuscate - ) -where - - - -#include "prelude.inc" - -import Data.Char -import System.Random - - - -obfuscate :: Text -> IO Text -obfuscate input = do - let predi x = isAlphaNum x || x `elem` "_'" - let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) - let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x - let filtered = filter exceptionFilter idents - mappings <- fmap Map.fromList $ filtered `forM` \x -> do - r <- createAlias x - pure (x, r) - let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings) - pure $ Text.concat $ fmap Text.pack groups' - -keywords :: [String] -keywords = - [ "case" - , "class" - , "data" - , "default" - , "deriving" - , "do" - , "mdo" - , "else" - , "forall" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "qualified" - , "then" - , "type" - , "where" - , "_" - , "foreign" - , "ccall" - , "as" - , "safe" - , "unsafe" - , "hiding" - , "proc" - , "rec" - , "family" - ] - -extraKWs :: [String] -extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] - -createAlias :: String -> IO String -createAlias xs = go NoHint xs - where - go _hint "" = pure "" - go hint (c : cr) = do - c' <- case hint of - VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] - VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c - cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr - pure (c' : cr') - -data Hint = NoHint | VocalHint | NoVocalHint - -_randomRange :: Random a => a -> a -> IO a -_randomRange lo hi = do - gen <- getStdGen - let (x, gen') = randomR (lo, hi) gen - setStdGen gen' - pure x - -randomFrom :: Random a => [a] -> IO a -randomFrom l = do - let hi = length l - 1 - gen <- getStdGen - let (x, gen') = randomR (0, hi) gen - setStdGen gen' - pure $ l List.!! x diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ /dev/null @@ -1,413 +0,0 @@ -module Language.Haskell.Brittany.Internal.Prelude - ( module E - , module Language.Haskell.Brittany.Internal.Prelude - ) -where - - - --- rather project-specific stuff: ---------------------------------- -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import GHC.Hs.Extension as E ( GhcPs ) -#else -import HsExtension as E ( GhcPs ) -#endif /* ghc-8.10.1 */ - -import RdrName as E ( RdrName ) -#if MIN_VERSION_ghc(8,8,0) -import qualified GHC ( dL, HasSrcSpan, SrcSpanLess ) -#endif -import qualified GHC ( Located ) - - --- more general: ----------------- - -import Data.Functor.Identity as E ( Identity(..) ) -import Control.Concurrent.Chan as E ( Chan ) -import Control.Concurrent.MVar as E ( MVar ) -import Data.Int as E ( Int ) -import Data.Word as E ( Word ) -import Prelude as E ( Integer - , Float - , Double - ) -import Control.Monad.ST as E ( ST ) -import Data.Bool as E ( Bool(..) ) -import Data.Char as E ( Char ) -import Data.Either as E ( Either(..) ) -import Data.IORef as E ( IORef ) -import Data.Maybe as E ( Maybe(..) ) -import Data.Semigroup as E ( Option(..) ) -import Data.Monoid as E ( Endo(..) - , All(..) - , Any(..) - , Sum(..) - , Product(..) - , Alt(..) - ) -import Data.Ord as E ( Ordering(..) - , Down(..) - ) -import Data.Ratio as E ( Ratio - , Rational - ) -import Data.String as E ( String ) -import Data.Void as E ( Void ) -import System.IO as E ( IO ) -import Data.Proxy as E ( Proxy(..) ) -import Data.Sequence as E ( Seq ) - -import Data.Map as E ( Map ) -import Data.Set as E ( Set ) - -import Data.Text as E ( Text ) - -import Prelude as E ( 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.Function as E ( fix - ) - -import Data.Foldable as E ( foldl' - , foldr' - , fold - , asum - ) - -import Data.List as E ( 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.List.NonEmpty as E ( NonEmpty(..) - , nonEmpty - ) - -import Data.Tuple as E ( swap - ) - -import Data.Char as E ( ord - , chr - ) - -import Data.Maybe as E ( fromMaybe - , maybe - , listToMaybe - , maybeToList - , catMaybes - ) - -import Data.Word as E ( Word32 - ) - -import Data.Ord as E ( comparing - , Down (..) - ) - -import Data.Either as E ( either - ) - -import Data.Ratio as E ( Ratio - , (%) - , numerator - , denominator - ) - -import Text.Read as E ( readMaybe - ) - -import Control.Monad as E ( 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 as E ( Applicative (..) - , Alternative (..) - ) - -import Foreign.Storable as E ( Storable ) -import GHC.Exts as E ( Constraint ) - -import Control.Concurrent as E ( threadDelay - , forkIO - , forkOS - ) - -import Control.Concurrent.MVar as E ( MVar - , newEmptyMVar - , newMVar - , putMVar - , readMVar - , takeMVar - , swapMVar - ) - -import Control.Exception as E ( evaluate - , bracket - , assert - ) - -import Debug.Trace as E ( trace - , traceId - , traceShowId - , traceShow - , traceStack - , traceShowId - , traceIO - , traceM - , traceShowM - ) - -import Foreign.ForeignPtr as E ( ForeignPtr - ) - -import Data.Monoid as E ( mconcat - , Monoid (..) - ) - -import Data.Bifunctor as E ( bimap ) -import Data.Functor as E ( (<$), ($>) ) -import Data.Function as E ( (&) ) -import Data.Semigroup as E ( (<>) - , Semigroup(..) - ) -import System.IO as E ( hFlush - , stdout - ) - -import Data.Typeable as E ( Typeable - ) - -import Control.Arrow as E ( first - , second - , (***) - , (&&&) - , (>>>) - , (<<<) - ) - -import Data.Functor.Identity as E ( Identity (..) - ) - -import Data.Proxy as E ( Proxy (..) - ) - -import Data.Version as E ( showVersion - ) - -import Data.List.Extra as E ( nubOrd - , stripSuffix - ) -import Control.Monad.Extra as E ( whenM - , unlessM - , ifM - , notM - , orM - , andM - , anyM - , allM - ) - -import Data.Tree as E ( Tree(..) - ) - -import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) - -- , MultiRWSTNull - -- , MultiRWS - -- , - MonadMultiReader(..) - , MonadMultiWriter(..) - , MonadMultiState(..) - , mGet - -- , 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 as E ( Text ) - -import Control.Monad.IO.Class as E ( MonadIO (..) - ) - -import Control.Monad.Trans.Class as E ( lift - ) -import Control.Monad.Trans.Maybe as E ( MaybeT (..) - ) - -import Data.Data as E ( toConstr - ) - -todo :: a -todo = error "todo" - - -#if MIN_VERSION_ghc(8,8,0) -ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) -ghcDL = GHC.dL -#else /* ghc-8.6 */ -ghcDL :: GHC.Located a -> GHC.Located a -ghcDL x = x -#endif diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Haskell.Brittany.Internal.PreludeUtils -where - - - -import Prelude -import qualified Data.Strict.Maybe as Strict -import Debug.Trace -import Control.Monad -import System.IO - -import Control.DeepSeq ( NFData, force ) -import Control.Exception.Base ( evaluate ) - -import Control.Applicative - - - -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 - -instance Alternative Strict.Maybe where - empty = Strict.Nothing - x <|> Strict.Nothing = x - _ <|> x = x - -traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) -traceFunctionWith name s1 s2 f x = trace traceStr y - where - y = f x - traceStr = - name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y - -(<&!>) :: Monad m => m a -> (a -> b) -> m b -(<&!>) = flip (<$!>) - -putStrErrLn :: String -> IO () -putStrErrLn s = hPutStrLn stderr s - -putStrErr :: String -> IO () -putStrErr s = hPutStr stderr s - -printErr :: Show a => a -> IO () -printErr = putStrErrLn . show - -errorIf :: Bool -> a -> a -errorIf False = id -errorIf True = error "errorIf" - -errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id -errorIfNote (Just x) = error x - -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = flip fmap -infixl 4 <&> - -(.>) :: (a -> b) -> (b -> c) -> (a -> c) -f .> g = g . f -infixl 9 .> - -evaluateDeep :: NFData a => a -> IO a -evaluateDeep = evaluate . force diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ /dev/null @@ -1,952 +0,0 @@ -#define INSERTTRACESALT 0 -#define INSERTTRACESALTVISIT 0 -#define INSERTTRACESGETSPACING 0 - -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Internal.Transformations.Alt - ( transformAlts - ) -where - - - -#include "prelude.inc" - -import Data.HList.ContainsType - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Control.Monad.Memo as Memo - - - -data AltCurPos = AltCurPos - { _acp_line :: Int -- chars in the current line - , _acp_indent :: Int -- current indentation level - , _acp_indentPrep :: Int -- indentChange affecting the next Par - , _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) - -altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction - -altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone -altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay 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 - ) - => BriDocNumbered - -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts = - MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) - . Memo.startEvalMemoT - . fmap unwrapBriDocNumbered - . rec - where - -- this function is exponential by nature and cannot be improved in any - -- way i can think of, and i've tried. (stupid StableNames.) - -- transWrap :: BriDoc -> BriDocNumbered - -- transWrap brDc = flip StateS.evalState (1::Int) - -- $ Memo.startEvalMemoT - -- $ go brDc - -- where - -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i - -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered - -- go = Memo.memo $ \bdX -> do - -- i <- lift $ incGet - -- fmap (\bd' -> (i,bd')) $ case bdX of - -- BDEmpty -> return $ BDFEmpty - -- BDLit t -> return $ BDFLit t - -- BDSeq list -> BDFSeq <$> go `mapM` list - -- BDCols sig list -> BDFCols sig <$> go `mapM` list - -- BDSeparator -> return $ BDFSeparator - -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd - -- BDSetBaseY bd -> BDFSetBaseY <$> go bd - -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd - -- BDPar ind line indented -> [ BDFPar ind line' indented' - -- | line' <- go line - -- , indented' <- go indented - -- ] - -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen - -- BDForceMultiline bd -> BDFForceMultiline <$> go bd - -- BDForceSingleline bd -> BDFForceSingleline <$> go bd - -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd - -- BDExternal k ks c t -> return $ BDFExternal k ks c t - -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd - -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd - -- BDLines lines -> BDFLines <$> go `mapM` lines - -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd - -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd - - - - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered - rec bdX@(brDcId, brDc) = do -#if INSERTTRACESALTVISIT - do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: visiting: " ++ case brDc of - BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp) - BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp) - _ -> show (toConstr brDc, acp) -#endif - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> - reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> - reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp - { _acp_indent = ind - , _acp_indentPrep = 0 - } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' - { _acp_line = ind - , _acp_indent = ind - } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> 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[]. - BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - 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{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - 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 - ++ ",hasSpace1=" ++ 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{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - 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)) - let checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) -#if INSERTTRACESALT - zip spacings options `forM_` \(vs, (_, bd)) -> - tellDebugMess $ " " ++ "spacing=" ++ show vs - ++ ",hasSpace2=" ++ show (hasSpace2 lconf acp <$> vs) - ++ ",lineCheck=" ++ show (lineCheck <$> vs) - ++ " " ++ show (toConstr bd) - tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions) -#endif - id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) - $ rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode 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 - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l:lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp - { _acp_line = ind - , _acp_indent = ind - } - rec x - return $ reWrap $ BDFLines (l':lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do - acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid (VerticalSpacing _ _ _) -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - -getSpacing - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => BriDocNumbered - -> m (LineModeValidity VerticalSpacing) -getSpacing !bridoc = rec bridoc - where - rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) - rec (brDcId, brDc) = do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - result <- case brDc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> - return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False - BDFSeq list -> - sumVs <$> rec `mapM` list - BDFCols _sig list -> sumVs <$> rec `mapM` list - BDFSeparator -> - return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur 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) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = VerticalSpacingParSome 0 - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVs <- rec sameLine - mIndSp <- rec indented - return - $ [ VerticalSpacing lsp pspResult parFlagResult - | VerticalSpacing lsp mPsp _ <- mVs - , indSp <- mIndSp - , lineMax <- getMaxVS $ mIndSp - , let pspResult = case mPsp of - VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax - , let parFlagResult = mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ] - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> do - mVs <- rec bd - return $ mVs >>= _vs_paragraph .> \case - VerticalSpacingParNone -> LineModeInvalid - _ -> mVs - BDFForceSingleline bd -> do - mVs <- rec bd - return $ mVs >>= _vs_paragraph .> \case - VerticalSpacingParNone -> mVs - _ -> LineModeInvalid - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False - BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return - $ LineModeValid - $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_:_) -> do - lSps <- rec `mapM` ls - let (mVs:_) = lSps -- separated into let to avoid MonadFail - return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp pf) -> - VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing b bd -> do - mVs <- rec bd - return - $ mVs - <|> LineModeValid - (VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r - return r -#if INSERTTRACESGETSPACING - tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result -#endif - return result - maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - maxVs = foldl' - (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing (max x1 y1) (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) False)) - (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - sumVs sps = foldl' (liftM2 go) initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y) - x3 - singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False - isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int - getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - -data SpecialCompare = Unequal | Smaller | Bigger - -getSpacings - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => Int - -> BriDocNumbered - -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] -getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where - -- when we do `take K . filter someCondition` on a list of spacings, we - -- need to first (also) limit the size of the input list, otherwise a - -- _large_ input with a similarly _large_ prefix not passing our filtering - -- process could lead to exponential runtime behaviour. - -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3*limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let specialCompare vs1 vs2 = - if ( (_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let allowHangingQuasiQuotes = - config - & _conf_layout - & _lconfig_allowHangingQuasiQuotes - & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> - fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur 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) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit - $ [ (x,y) - | x<-mVss - , y<-indSps - ] - return $ mVsIndSp <&> - \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp) - ( mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> - return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1 ] -> VerticalSpacing - (Text.length t1) - VerticalSpacingParNone - False - (t1 : _) -> VerticalSpacing - (Text.length t1) - (VerticalSpacingParAlways 0) - True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_:_) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let worbled = fmap reverse - $ sequence - $ reverse - $ lSpss - sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - sumF [] = error $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse 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 $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then [VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) - return r -#if INSERTTRACESGETSPACING - case brdc of - BDFAnnotationPrior{} -> return () - BDFAnnotationRest{} -> return () - _ -> mTell $ Seq.fromList ["getSpacings: visiting: " - ++ show (toConstr $ brdc) -- (briDocToDoc $ unwrapBriDocNumbered (0, brdc)) - , " -> " - ++ show (take 9 result) - ] -#endif - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) - False) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i - -fixIndentationForMultiple - :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int -fixIndentationForMultiple acp indent = do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - -- for IndentPolicyMultiple, we restrict the amount of added - -- indentation in such a manner that we end up on a multiple of the - -- base indentation. - indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - pure $ if indPolicy == IndentPolicyMultiple - then - let indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 - else indAddRaw diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ /dev/null @@ -1,138 +0,0 @@ -module Language.Haskell.Brittany.Internal.Transformations.Columns - ( transformSimplifyColumns - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate - - - -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 $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) - | all (\case BDSeparator -> True; _ -> False) rest -> - Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) - 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 - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - -- 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 - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing - BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing - BDForceSingleline{} -> Nothing - BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing - BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing - BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing - BDNonBottomSpacing _ x -> Just x diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ /dev/null @@ -1,198 +0,0 @@ -module Language.Haskell.Brittany.Internal.Transformations.Floating - ( transformSimplifyFloating - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate - - - --- 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. - -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence - -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> - Just x - -- AddIndent floats into Lines. - 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] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> - Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> - Just $ x - -- AddIndent floats into Lines. - 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 - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Language.Haskell.Brittany.Internal.Transformations.Indent - ( transformSimplifyIndent - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate - - - --- 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 BrIndentNone _ _ -> Nothing - BDPar ind x indented -> - Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind 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] - BDLines [l] -> Just l - BDAddBaseY i (BDAnnotationPrior k x) -> - Just $ BDAnnotationPrior k (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationKW k kw x) -> - Just $ BDAnnotationKW k kw (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationRest k x) -> - Just $ BDAnnotationRest k (BDAddBaseY i x) - BDAddBaseY i (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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Language.Haskell.Brittany.Internal.Transformations.Par - ( transformSimplifyPar - ) -where - - - -#include "prelude.inc" - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate - - - -transformSimplifyPar :: BriDoc -> BriDoc -transformSimplifyPar = transformUp $ \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]) - x@(BDPar _ (BDPar _ BDPar{} _) _) -> x - BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> - BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) - BDPar ind1 (BDPar ind2 line p1) p2 -> - BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs - where - go = (=<<) $ \case - BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> 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 -> x - x -> x diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} - -module Language.Haskell.Brittany.Internal.Types -where - - - -#include "prelude.inc" - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId, SrcSpan ) - -import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) -import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey ) - -import Language.Haskell.Brittany.Internal.Config.Types - -import Data.Generics.Uniplate.Direct as Uniplate - - - -data PerItemConfig = PerItemConfig - { _icd_perBinding :: Map String (CConfig Option) - , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option) - } - deriving Data.Data.Data - -type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] - '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] - -type PPMLocal = MultiRWSS.MultiRWS - '[Config, ExactPrint.Anns] - '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] - -newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) - -data LayoutState = LayoutState - { _lstate_baseYs :: [Int] - -- ^ stack of number of current indentation columns - -- (not number of indentations). - , _lstate_curYOrAddNewline :: Either Int Int - -- ^ Either: - -- 1) number of chars in the current line. - -- 2) number of newlines to be inserted before inserting any - -- non-space elements. - , _lstate_indLevels :: [Int] - -- ^ stack of current indentation levels. set for - -- any layout-affected elements such as - -- let/do/case/where elements. - -- The main purpose of this member is to - -- properly align comments, as their - -- annotation positions are relative to the - -- current layout indentation level. - , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for - -- properly treating cases where comments - -- on the first indented element have an - -- annotation offset relative to the last - -- non-indented element, which is confusing. - , _lstate_comments :: Anns - , _lstate_commentCol :: Maybe Int -- this communicates two things: - -- firstly, that cursor is currently - -- at the end of a comment (so needs - -- newline before any actual content). - -- secondly, the column at which - -- insertion of comments started. - , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone - -- writes (any non-spaces) in the - -- current line. - -- , _lstate_isNewline :: NewLineState - -- -- captures if the layouter currently is in a new line, i.e. if the - -- -- current line only contains (indentation) spaces. - -- this is mostly superseeded by curYOrAddNewline, iirc. - , _lstate_commentNewlines :: Int -- number of newlines inserted due to - -- move-to-DP at a start of a comment. - -- Necessary because some keyword DPs - -- are relative to the last non-comment - -- entity (for some reason). - -- This is not very strictly reset to 0, - -- so we might in some cases get "artifacts" - -- from previous document elements. - -- But the worst effect at the moment would - -- be that we introduce less newlines on - -- moveToKWDP, which seems harmless enough. - } - -lstate_baseY :: LayoutState -> Int -lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs - -lstate_indLevel :: LayoutState -> Int -lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels - --- evil, incomplete Show instance; only for debugging. -instance Show LayoutState where - show state = - "LayoutState" - ++ "{baseYs=" ++ show (_lstate_baseYs state) - ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) - ++ ",indLevels=" ++ show (_lstate_indLevels state) - ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) - ++ ",commentCol=" ++ show (_lstate_commentCol state) - ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) - ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) - ++ "}" - --- 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 BrittanyError - = ErrorInput String - -- ^ parsing failed - | ErrorUnusedComment String - -- ^ internal error: some comment went missing - | ErrorMacroConfig String String - -- ^ in-source config string parsing error; first argument is the parser - -- output and second the corresponding, ill-formed input. - | LayoutWarning String - -- ^ some warning - | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) - -- ^ internal error: pretty-printing is not implemented for type of node - -- in the syntax-tree - | ErrorOutputCheck - -- ^ checking the output for syntactic validity failed - -data BriSpacing = BriSpacing - { _bs_spacePastLineIndent :: Int -- space in the current, - -- potentially somewhat filled - -- line. - , _bs_spacePastIndent :: Int -- space required in properly - -- indented blocks below the - -- current line. - } - -data ColSig - = ColTyOpPrefix - -- any prefixed operator/paren/"::"/.. - -- expected to have exactly two colums. - -- e.g. ":: foo" - -- 111222 - -- "-> bar asd asd" - -- 11122222222222 - | ColPatternsFuncPrefix - -- pattern-part of the lhs, e.g. "func (foo a b) c _". - -- Has variable number of columns depending on the number of patterns. - | ColPatternsFuncInfix - -- pattern-part of the lhs, e.g. "Foo a <> Foo b". - -- Has variable number of columns depending on the number of patterns. - | ColPatterns - | ColCasePattern - | ColBindingLine (Maybe Text) - -- e.g. "func pat pat = expr" - -- 1111111111111222222 - -- or "pat | stmt -> expr" - -- 111111111112222222 - -- expected to have exactly two columns. - | ColGuard - -- e.g. "func pat pat | cond = ..." - -- 11111111111112222222 - -- or "pat | cond1, cond2 -> ..." - -- 1111222222222222222 - -- expected to have exactly two columns - | ColGuardedBody - -- e.g. | foofoo = 1 - -- | bar = 2 - -- 111111111222 - -- expected to have exactly two columns - | ColBindStmt - | ColDoLet -- the non-indented variant - | ColRec - | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? - | ColRecDecl - | ColListComp - | ColList - | ColApp Text - | ColTuple - | ColTuples - | ColOpPrefix -- merge with ColList ? other stuff? - | ColImport - - -- TODO - deriving (Eq, Ord, Data.Data.Data, Show) - -data BrIndent = BrIndentNone - | BrIndentRegular - | BrIndentSpecial Int - deriving (Eq, Ord, Typeable, Data.Data.Data, Show) - -type ToBriDocM = MultiRWSS.MultiRWS - '[Config, Anns] -- reader - '[[BrittanyError], Seq String] -- writer - '[NodeAllocIndex] -- state - -type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c - -data DocMultiLine - = MultiLineNo - | MultiLinePossible - deriving (Eq, Typeable) - --- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot --- of transformations on `BriDocF Identity`s and it is really annoying to --- `Identity`/`runIdentity` everywhere. -data BriDoc - = -- BDWrapAnnKey AnnKey BriDoc - BDEmpty - | BDLit !Text - | BDSeq [BriDoc] -- elements other than the last should - -- not contains BDPars. - | BDCols ColSig [BriDoc] -- elements other than the last - -- should not contains BDPars - | BDSeparator -- semantically, space-unless-at-end-of-line. - | BDAddBaseY BrIndent BriDoc - | BDBaseYPushCur BriDoc - | BDBaseYPop BriDoc - | BDIndentLevelPushCur BriDoc - | BDIndentLevelPop BriDoc - | BDPar - { _bdpar_indent :: BrIndent - , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars - , _bdpar_indented :: BriDoc - } - -- | BDAddIndent BrIndent (BriDocF f) - -- | BDNewline - | BDAlt [BriDoc] - | BDForwardLineMode BriDoc - | BDExternal AnnKey - (Set AnnKey) -- set of annkeys contained within the node - -- to be printed via exactprint - Bool -- should print extra comment ? - Text - | BDPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) - | BDAnnotationPrior AnnKey BriDoc - | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc - | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset - | BDLines [BriDoc] - | BDEnsureIndent BrIndent BriDoc - -- the following constructors are only relevant for the alt transformation - -- and are removed afterwards. They should never occur in any BriDoc - -- after the alt transformation. - | BDForceMultiline BriDoc - | BDForceSingleline BriDoc - | BDNonBottomSpacing Bool BriDoc - | BDSetParSpacing BriDoc - | BDForceParSpacing BriDoc - -- pseudo-deprecated - | BDDebug String BriDoc - deriving (Data.Data.Data, Eq, Ord) - -data BriDocF f - = -- BDWrapAnnKey AnnKey BriDoc - BDFEmpty - | BDFLit !Text - | BDFSeq [f (BriDocF f)] -- elements other than the last should - -- not contains BDPars. - | BDFCols ColSig [f (BriDocF f)] -- elements other than the last - -- should not contains BDPars - | BDFSeparator -- semantically, space-unless-at-end-of-line. - | BDFAddBaseY BrIndent (f (BriDocF f)) - | BDFBaseYPushCur (f (BriDocF f)) - | BDFBaseYPop (f (BriDocF f)) - | BDFIndentLevelPushCur (f (BriDocF f)) - | BDFIndentLevelPop (f (BriDocF f)) - | BDFPar - { _bdfpar_indent :: BrIndent - , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars - , _bdfpar_indented :: f (BriDocF f) - } - -- | BDAddIndent BrIndent (BriDocF f) - -- | BDNewline - | BDFAlt [f (BriDocF f)] - | BDFForwardLineMode (f (BriDocF f)) - | BDFExternal AnnKey - (Set AnnKey) -- set of annkeys contained within the node - -- to be printed via exactprint - Bool -- should print extra comment ? - Text - | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) - | BDFAnnotationPrior AnnKey (f (BriDocF f)) - | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) - | BDFAnnotationRest AnnKey (f (BriDocF f)) - | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset - | BDFLines [(f (BriDocF f))] - | BDFEnsureIndent BrIndent (f (BriDocF f)) - | BDFForceMultiline (f (BriDocF f)) - | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing Bool (f (BriDocF f)) - | BDFSetParSpacing (f (BriDocF f)) - | BDFForceParSpacing (f (BriDocF f)) - | BDFDebug String (f (BriDocF f)) - --- deriving instance Data.Data.Data (BriDocF Identity) -deriving instance Data.Data.Data (BriDocF ((,) Int)) - -type BriDocFInt = BriDocF ((,) Int) -type BriDocNumbered = (Int, BriDocFInt) - -instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list ) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts ) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - uniplate (BDAnnotationPrior annKey bd) = - plate BDAnnotationPrior |- annKey |* bd - uniplate (BDAnnotationKW annKey kw bd) = - plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = - plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw b bd) = - plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines ) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd - -newtype NodeAllocIndex = NodeAllocIndex Int - --- TODO: rename to "dropLabels" ? -unwrapBriDocNumbered :: BriDocNumbered -> BriDoc -unwrapBriDocNumbered tpl = case snd tpl of - BDFEmpty -> BDEmpty - BDFLit t -> BDLit t - BDFSeq list -> BDSeq $ rec <$> list - BDFCols sig list -> BDCols sig $ rec <$> list - BDFSeparator -> BDSeparator - BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDFBaseYPop bd -> BDBaseYPop $ rec bd - BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDFPar ind line indented -> BDPar ind (rec line) (rec indented) - BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDFForwardLineMode bd -> BDForwardLineMode $ rec bd - BDFExternal k ks c t -> BDExternal k ks c t - BDFPlain t -> BDPlain t - BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd - BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd - BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd - BDFLines lines -> BDLines $ rec <$> lines - BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where rec = unwrapBriDocNumbered - -isNotEmpty :: BriDoc -> Bool -isNotEmpty BDEmpty = False -isNotEmpty _ = True - --- this might not work. is not used anywhere either. -briDocSeqSpine :: BriDoc -> () -briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd - BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDPlain{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd - -briDocForceSpine :: BriDoc -> BriDoc -briDocForceSpine bd = briDocSeqSpine bd `seq` bd - - -data VerticalSpacingPar - = VerticalSpacingParNone -- no indented lines - | VerticalSpacingParSome Int -- indented lines, requiring this much - -- vertical space at most - | VerticalSpacingParAlways Int -- indented lines, requiring this much - -- vertical space at most, but should - -- be considered as having space for - -- any spacing validity check. - -- TODO: it might be wrong not to extend "always" to the none case, i.e. - -- we might get better properties of spacing operators by having a - -- product like (Normal|Always, None|Some Int). - deriving (Eq, Show) - -data VerticalSpacing - = VerticalSpacing - { _vs_sameLine :: !Int - , _vs_paragraph :: !VerticalSpacingPar - , _vs_parFlag :: !Bool - } - deriving (Eq, Show) - -newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) - deriving (Functor, Applicative, Monad, Show, Alternative) - -pattern LineModeValid :: forall t. t -> LineModeValidity t -pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t -pattern LineModeInvalid :: forall t. LineModeValidity t -pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Language.Haskell.Brittany.Internal.Utils - ( parDoc - , parDocW - , fromMaybeIdentity - , fromOptionIdentity - , traceIfDumpConf - , mModify - , customLayouterF - , astToDoc - , briDocToDoc - -- , displayBriDocSimpleTree - , annsDoc - , Max (..) - , tellDebugMess - , tellDebugMessShow - , briDocToDocWithAnns - , breakEither - , spanMaybe - , transformUp - , transformDownMay - , FirstLastView(..) - , splitFirstLast - , lines' - , showOutputable - , absurdExt - ) -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.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -import qualified GHC.Hs.Extension as HsExtension -#else -import qualified HsExtension -#endif /* ghc-8.10.1 */ - - - -parDoc :: String -> PP.Doc -parDoc = PP.fsep . fmap PP.text . List.words - -parDocW :: [String] -> PP.Doc -parDocW = PP.fsep . fmap PP.text . List.words . List.unwords - - -showSDoc_ :: GHC.SDoc -> String -showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags - -showOutputable :: (GHC.Outputable a) => a -> String -showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags - -fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y - -fromOptionIdentity :: Identity a -> Option a -> Identity a -fromOptionIdentity x y = - Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y - --- maximum monoid over N+0 --- or more than N, because Num is allowed. -newtype Max a = Max { getMax :: a } - deriving (Eq, Ord, Show, Bounded, Num) - -instance (Num a, Ord a) => Semigroup (Max a) where - (<>) = Data.Coerce.coerce (max :: a -> a -> a) - -instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 - mappend = (<>) - -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)++"}" - $ "{" ++ showOutputable ss ++ "}" - located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter - located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a - where - annStr = case cast ss of - Just (s :: GHC.SrcSpan) -> - ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) - Nothing -> ShowIsId "nnnnnnnn" - -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 (Semigroup.Last Bool)) - -> a - -> m () -traceIfDumpConf s accessor val = do - whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do - trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () - -tellDebugMess :: MonadMultiWriter - (Seq String) m => String -> m () -tellDebugMess s = mTell $ Seq.singleton s - -tellDebugMessShow :: forall a m . (MonadMultiWriter - (Seq String) m, Show a) => a -> m () -tellDebugMessShow = tellDebugMess . show - --- i should really put that into multistate.. -mModify :: MonadMultiState s m => (s -> s) -> m () -mModify f = mGet >>= mSet . f - -astToDoc :: Data ast => ast -> PP.Doc -astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast - -briDocToDoc :: BriDoc -> PP.Doc -briDocToDoc = astToDoc . removeAnnotations - where - removeAnnotations = Uniplate.transform $ \case - BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x - -briDocToDocWithAnns :: BriDoc -> PP.Doc -briDocToDocWithAnns = astToDoc - -annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) - -breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1:aR) = case fn a1 of - Left b -> (b : bs, cs) - Right c -> (bs, c : cs) - where - (bs, cs) = breakEither fn aR - -spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) - where - (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) - -data FirstLastView a - = FirstLastEmpty - | FirstLastSingleton a - | FirstLast a [a] a - -splitFirstLast :: [a] -> FirstLastView a -splitFirstLast [] = FirstLastEmpty -splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) - --- TODO: move to uniplate upstream? --- aka `transform` -transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -transformUp f = g where g = f . Uniplate.descend g -_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -_transformDown f = g where g = Uniplate.descend g . f -transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x -_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x - --- | similar to List.lines, but treating the case of final newline character --- in such a manner that this function is the inverse of @intercalate "\n"@. -lines' :: String -> [String] -lines' s = case break (== '\n') s of - (s1, []) -> [s1] - (s1, [_]) -> [s1, ""] - (s1, (_:r)) -> s1 : lines' r - -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -absurdExt :: HsExtension.NoExtCon -> a -absurdExt = HsExtension.noExtCon -#else --- | A method to dismiss NoExt patterns for total matches -absurdExt :: HsExtension.NoExt -> a -absurdExt = error "cannot construct NoExt" -#endif diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs deleted file mode 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ /dev/null @@ -1,484 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Language.Haskell.Brittany.Main (main) where - - - -#include "prelude.inc" - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -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.Monoid - -import GHC ( GenLocated(L) ) -import Outputable ( Outputable(..) - , showSDocUnsafe - ) - -import Text.Read ( Read(..) ) -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Control.Monad ( zipWithM ) -import Data.CZipWith - -import qualified Debug.Trace as Trace - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Obfuscation - -import qualified Text.PrettyPrint as PP - -import DataTreePrint -import UI.Butcher.Monadic - -import qualified System.Exit -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Paths_brittany - - - -data WriteMode = Display | Inplace - -instance Read WriteMode where - readPrec = val "display" Display <|> val "inplace" Inplace - where val iden v = ReadPrec.lift $ ReadP.string iden >> return v - -instance Show WriteMode where - show Display = "display" - show Inplace = "inplace" - - -main :: IO () -main = mainFromCmdParserWithHelpDesc mainCmdParser - -helpDoc :: PP.Doc -helpDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDocW - [ "Reformats one or more haskell modules." - , "Currently affects only the module head (imports/exports), type" - , "signatures and function bindings;" - , "everything else is left unmodified." - , "Based on ghc-exactprint, thus (theoretically) supporting all" - , "that ghc does." - ] - , parDoc $ "Example invocations:" - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany" - , PP.nest 2 $ PP.text "read from stdin, output to stdout" - ] - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" - , PP.nest 2 $ PP.vcat - [ PP.text "run on all modules in current directory (no backup!)" - , PP.text "4 spaces indentation" - ] - ] - , parDocW - [ "This program is written carefully and contains safeguards to ensure" - , "the output is syntactically valid and that no comments are removed." - , "Nonetheless, this is a young project, and there will always be bugs," - , "and ensuring that the transformation never changes semantics of the" - , "transformed source is currently not possible." - , "Please do check the output and do not let brittany override your large" - , "codebase without having backups." - ] - , parDoc $ "There is NO WARRANTY, to the extent permitted by law." - , parDocW - [ "This program is free software released under the AGPLv3." - , "For details use the --license flag." - ] - , parDoc $ "See https://github.com/lspitzner/brittany" - , parDoc - $ "Please report bugs at" - ++ " https://github.com/lspitzner/brittany/issues" - ] - -licenseDoc :: PP.Doc -licenseDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" - , parDoc $ "Copyright (C) 2019 PRODA LTD" - , parDocW - [ "This program is free software: you can redistribute it and/or modify" - , "it under the terms of the GNU Affero General Public License," - , "version 3, as published by the Free Software Foundation." - ] - , parDocW - [ "This program is distributed in the hope that it will be useful," - , "but WITHOUT ANY WARRANTY; without even the implied warranty of" - , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , "GNU Affero General Public License for more details." - ] - , parDocW - [ "You should have received a copy of the GNU Affero General Public" - , "License along with this program. If not, see" - , "." - ] - ] - - -mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () -mainCmdParser helpDesc = do - addCmdSynopsis "haskell source pretty printer" - addCmdHelp $ helpDoc - -- addCmd "debugArgs" $ do - addHelpCommand helpDesc - addCmd "license" $ addCmdImpl $ print $ licenseDoc - -- addButcherDebugCommand - reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser - 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]") - checkMode <- addSimpleBoolFlag - "c" - ["check-mode"] - (flagHelp - (PP.vcat - [ PP.text "check for changes but do not write them out" - , PP.text "exits with code 0 if no changes necessary, 1 otherwise" - , PP.text "and print file path(s) of files that have changes to stdout" - ] - ) - ) - writeMode <- addFlagReadParam - "" - ["write-mode"] - "(display|inplace)" - ( flagHelp - (PP.vcat - [ PP.text "display: output for any input(s) goes to stdout" - , PP.text "inplace: override respective input file (without backup!)" - ] - ) - Data.Monoid.<> flagDefault Display - ) - inputParams <- addParamNoFlagStrings - "PATH" - (paramHelpStr "paths to input/inout haskell source files") - reorderStop - addCmdImpl $ void $ do - when printLicense $ do - print licenseDoc - System.Exit.exitSuccess - when printVersion $ do - do - putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" - putStrLn $ "Copyright (C) 2019 PRODA LTD" - putStrLn $ "There is NO WARRANTY, to the extent permitted by law." - System.Exit.exitSuccess - when printHelp $ do - liftIO - $ putStrLn - $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } - $ ppHelpShallow helpDesc - System.Exit.exitSuccess - - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths - - configsToLoad <- liftIO $ if null configPaths - then - maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths - - config <- - runMaybeT - (if noUserConfig - then readConfigs cmdlineConfig configsToLoad - else readConfigsWithUserConfig cmdlineConfig configsToLoad - ) - >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x - when (config & _conf_debug & _dconf_dump_config & confUnpack) - $ trace (showConfigYaml config) - $ return () - - results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths - - if checkMode - then when (any (== Changes) (Data.Either.rights results)) - $ System.Exit.exitWith (System.Exit.ExitFailure 1) - else case results of - xs | all Data.Either.isRight xs -> pure () - [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) - - -data ChangeStatus = Changes | NoChanges - deriving (Eq) - --- | The main IO parts for the default mode of operation, and after commandline --- and config stuff is processed. -coreIO - :: (String -> IO ()) -- ^ error output function. In parallel operation, you - -- may want serialize the different outputs and - -- consequently not directly print to stderr. - -> Config -- ^ global program config. - -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so - -- currently not part of program config. - -> Bool -- ^ whether we are (just) in check mode. - -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. - -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. - -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = - ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - -- there is a good of code duplication between the following code and the - -- `pureModuleTransform` function. Unfortunately, there are also a good - -- amount of slight differences: This module is a bit more verbose, and - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- the flag will do the following: insert a marker string - -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - -- The flag is intentionally misspelled to prevent clashing with - -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - (parseResult, originalContents) <- case inputPathM of - Nothing -> do - -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id - inputString <- liftIO $ System.IO.hGetContents System.IO.stdin - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) - return (parseRes, Text.pack inputString) - Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc - inputText <- Text.IO.readFile p - -- The above means we read the file twice, but the - -- GHC API does not really expose the source it - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> - -- handle still open -> write below crashes - evil.) - return (parseRes, inputText) - case parseResult of - Left left -> do - putErrorLn "parse error:" - putErrorLn left - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - of - Left (err, input) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - ExceptT.throwE 61 - Right c -> -- trace (showTree c) $ - pure c - let moduleConf = cZipWith fromOptionIdentity config inlineConf - when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - let disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack - (errsWarns, outSText, hasChanges) <- do - if - | disableFormatting -> do - pure ([], originalContents, False) - | exactprintOnly -> do - let r = Text.pack $ ExactPrint.exactPrint parsedSource anns - pure ([], r, r /= originalContents) - | otherwise -> do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return - $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ fmap hackF - $ TextL.splitOn (TextL.pack "\n") outRaw - else outRaw - out' <- if moduleConf & _conf_obfuscate & confUnpack - then lift $ obfuscate out - else pure out - pure $ (ews, out', out' /= originalContents) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 - when (not $ null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{} : _) -> do - putErrorLn - $ "ERROR: brittany pretty printer" - ++ " returned syntactically invalid result." - (ErrorInput str : _) -> do - putErrorLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{} : _) -> do - putErrorLn - $ "WARNING: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) - when - ( config - & _conf_debug - & _dconf_dump_ast_unknown - & confUnpack - ) - $ do - putErrorLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - putErrorLn - " -> falling back on exactprint for this element of the module" - warns@(LayoutWarning{} : _) -> do - putErrorLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{} : _) -> do - putErrorLn - $ "Error: detected unprocessed comments." - ++ " The transformation output will most likely" - ++ " not contain some of the comments" - ++ " present in the input haskell source file." - putErrorLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" - (ErrorMacroConfig err input : _) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - [] -> 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 & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - outputOnErrs = - config - & _conf_errorHandling - & _econf_produceOutputOnErrors - & confUnpack - shouldOutput = - not suppressOutput - && not checkMode - && (not hasErrors || outputOnErrs) - - when shouldOutput - $ addTraceSep (_conf_debug config) - $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges - unless isIdentical $ Text.IO.writeFile p $ outSText - - when (checkMode && hasChanges) $ case inputPathM of - Nothing -> pure () - Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p - - when hasErrors $ ExceptT.throwE 70 - return (if hasChanges then Changes else NoChanges) - where - addTraceSep conf = - if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] - then trace "----" - else id diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc deleted file mode 100644 --- a/srcinc/prelude.inc +++ /dev/null @@ -1,147 +0,0 @@ -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 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.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.Lazy --- import qualified Data.Text.Lazy.Builder - --- 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 Debug.Trace --- import qualified Numeric --- import qualified Numeric.Natural -import qualified System.IO --- import qualified Unsafe.Coerce - -import qualified Data.Bool as Bool -import qualified Data.Foldable as Foldable -import qualified GHC.OldList as List - -import qualified Data.Semigroup as Semigroup - -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as ByteStringL - -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.Map as Map -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.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.Except as ExceptT - -import qualified Data.Strict.Maybe as Strict - -import qualified Safe as Safe - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils