From bc70eb07e847ef317d2d1523b3491840a869b118 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 31 Jan 2017 18:37:21 +0100 Subject: [PATCH] Change config setup(!), Refactor, Update deps - config now uses foo_bar instead of _foo_bar; - config now will accept missing keys; - use latest butcher version; - improve identity testing by moving into separate file. --- brittany.cabal | 79 +- docs/hcar/Brittany.tex | 54 ++ src-brittany/Main.hs | 8 +- src-literatetests/Main.hs | 152 ++++ src-literatetests/tests.blt | 675 +++++++++++++++ src-unittests/IdentityTests.hs | 780 ------------------ src-unittests/TestMain.hs | 2 - src/Language/Haskell/Brittany/Config/Types.hs | 113 ++- stack.yaml | 4 +- 9 files changed, 1044 insertions(+), 823 deletions(-) create mode 100644 docs/hcar/Brittany.tex create mode 100644 src-literatetests/Main.hs create mode 100644 src-literatetests/tests.blt delete mode 100644 src-unittests/IdentityTests.hs diff --git a/brittany.cabal b/brittany.cabal index 096538a..31c4ab2 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.7.1.0 +version: 0.8.0.0 -- synopsis: -- description: license: AllRightsReserved @@ -50,6 +50,7 @@ library { Language.Haskell.Brittany.Transformations.Par Language.Haskell.Brittany.Transformations.Columns Language.Haskell.Brittany.Transformations.Indent + Paths_brittany } ghc-options: { -Wall @@ -78,9 +79,10 @@ library { , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.3 , lens - , butcher >=0.2.0.0 && <0.3 + , butcher >=1.0.0.0 && <1.1 , yaml >=0.8.18 && <0.9 - , extra >=1.4.10 && <1.5 + , aeson >=1.0.1.0 && <1.3 + , extra >=1.4.10 && <1.6 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 , monad-memo >=0.4.1 && <0.5 @@ -217,8 +219,7 @@ test-suite unittests } ghc-options: -Wall main-is: TestMain.hs - other-modules: IdentityTests - TestUtils + other-modules: TestUtils AsymptoticPerfTests hs-source-dirs: src-unittests default-extensions: { @@ -247,3 +248,71 @@ test-suite unittests if flag(brittany-dev) { ghc-options: -O0 -Werror -fobject-code } + +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 >=4.9 && <4.10 + , ghc + , ghc-paths + , ghc-exactprint + , transformers + , containers + , mtl + , text + , multistate + , syb + , neat-interpolation + , hspec + , data-tree-print + , pretty + , bytestring + , directory + , lens + , butcher + , yaml + , extra + , uniplate + , strict + , monad-memo + , safe + , either + , parsec + } + ghc-options: -Wall + main-is: Main.hs + other-modules: + hs-source-dirs: src-literatetests + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -j + -fno-warn-unused-imports + -fno-warn-orphans + -rtsopts + -with-rtsopts "-M2G" + } + if flag(brittany-dev) { + ghc-options: -O0 -Werror -fobject-code + } diff --git a/docs/hcar/Brittany.tex b/docs/hcar/Brittany.tex new file mode 100644 index 0000000..5c6760d --- /dev/null +++ b/docs/hcar/Brittany.tex @@ -0,0 +1,54 @@ +% Brittany-LE.tex +\begin{hcarentry}[new]{Brittany} +\report{Lennart Spitzner}%11/16 +\status{work in progress} +\makeheader + +Brittany is a Haskell source code formatting tool. It is based on +ghc-exactprint and thus uses the ghc parser, in contrast to tools based on +haskell-src-exts such as hindent or haskell-formatter. + +The goals of the project are to: + +\begin{compactitem} +\item + support the full ghc-haskell syntax including syntactic extensions; +\item + retain newlines and comments unmodified (to the degree possible when code + around them gets reformatted); +\item + be clever about using horizontal space while not overflowing it if it cannot + be avoided; +\item + have linear complexity in the size of the input text / the number of + syntactic nodes in the input. +\item + support horizontal alignments (e.g. different equations/pattern matches in + the some function's definition). +\end{compactitem} + +In contrast to other formatters brittany internally works in two steps: Firstly +transforming the syntax tree into a document tree representation, similar to +the document representation in general-purpose pretty-printers such as the +\emph{pretty} package, but much more specialized for the specific purpose of +handling a Haskell source code document. Secondly this document representation +is transformed into the output text document. This approach allows to handle +many different syntactic constructs in a uniform way, making it possible +to attain the above goals with a manageable amount of work. + +Brittany is work in progress; currently only type signatures and function +bindings are transformed, and not all syntactic constructs are supported. +Nonetheless Brittany is safe to try/use as there are checks in place to +ensure that the output is syntactically valid. + +Brittany requires ghc-8, and is not released on hackage yet; for a description +of how to build it see the repository README. + +\FurtherReading +{\small +\begin{compactitem} + \item + \url{https://github.com/lspitzner/brittany} +\end{compactitem} +} +\end{hcarentry} diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 1e16143..b28cd9a 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -39,10 +39,10 @@ import Paths_brittany main :: IO () -main = mainFromCmdParser mainCmdParser +main = mainFromCmdParserWithHelpDesc mainCmdParser -mainCmdParser :: CmdParser Identity (IO ()) () -mainCmdParser = do +mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () +mainCmdParser helpDesc = do addCmdSynopsis "haskell source pretty printer" addCmdHelp $ PP.vcat $ List.intersperse (PP.text "") [ parDoc $ "Transforms one haskell module by reformatting" @@ -60,7 +60,7 @@ mainCmdParser = do ++ " https://github.com/lspitzner/brittany/issues" ] -- addCmd "debugArgs" $ do - addHelpCommand + addHelpCommand helpDesc -- addButcherDebugCommand reorderStart printHelp <- addSimpleBoolFlag "" ["help"] mempty diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs new file mode 100644 index 0000000..4fe1e1e --- /dev/null +++ b/src-literatetests/Main.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import qualified Text.Parsec as Parsec +import Text.Parsec.Text ( Parser ) + +import Data.Char ( isSpace ) +import Data.List ( groupBy ) + +import Language.Haskell.Brittany + +import Language.Haskell.Brittany.Config.Types + +import Data.Coerce ( coerce ) + +import qualified Data.Text.IO as Text.IO + + + +data InputLine + = GroupLine Text + | HeaderLine Text + | PendingLine + | NormalLine Text + | CommentLine + deriving Show + + +main :: IO () +main = do + input <- Text.IO.readFile "src-literatetests/tests.blt" + let groups = createChunks input + hspec $ groups `forM_` \(groupname, tests) -> do + describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do + (if pend then before_ pending else id) + $ it (Text.unpack name) $ roundTripEqual inp + + 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, [(Text, Bool, Text)])] + 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 (\case + GroupLine g:grouprest -> + (,) g + $ 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 + ) + $ groupBy grouperT + $ filter (not . lineIsSpace) + $ grouprest + l -> error $ "first non-empty line must be a #group\n" ++ show l + ) + $ groupBy grouperG + $ filter (not . lineIsSpace) + $ lineMapper + <$> Text.lines input + where + extractNormal (NormalLine l) = Just l + extractNormal _ = Nothing + 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 + ] + , [ 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 + ] + ] + 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 :: Text -> Expectation +roundTripEqual t = + fmap (fmap PPTextWrapper) + (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) + `shouldReturn` Right (PPTextWrapper t) + +newtype PPTextWrapper = PPTextWrapper Text + deriving Eq + +instance Show PPTextWrapper where + show (PPTextWrapper t) = "\n" ++ Text.unpack t + + +defaultTestConfig :: Config +defaultTestConfig = Config + { _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = 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_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + } + , _conf_errorHandling = _conf_errorHandling staticDefaultConfig + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] + } + } + diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt new file mode 100644 index 0000000..6a29ddf --- /dev/null +++ b/src-literatetests/tests.blt @@ -0,0 +1,675 @@ + +############################################################################### +############################################################################### +############################################################################### +#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 #-} +--this comment is necessary for whatever reason.. +func :: forall (a :: *) b . a -> b + +#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 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 + + +############################################################################### +############################################################################### +############################################################################### +#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) + + + +############################################################################### +############################################################################### +############################################################################### +#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 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_indent = _lstate_indent state + } + +#test record update indentation 3 +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_indent = _lstate_indent 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 +#pending "TODO" +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)) + ] + diff --git a/src-unittests/IdentityTests.hs b/src-unittests/IdentityTests.hs deleted file mode 100644 index 71d699b..0000000 --- a/src-unittests/IdentityTests.hs +++ /dev/null @@ -1,780 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module IdentityTests - ( identityTests - ) -where - - - -#include "prelude.inc" - -import Test.Hspec - -import NeatInterpolation - -import Language.Haskell.Brittany - -import TestUtils - - - -identityTests :: Spec -identityTests = do - describe "type signatures" $ typeSignatureTests - describe "equation" $ do - describe "basic" $ basicEquationTests - describe "patterns" $ patternTests - describe "guards" $ guardTests - describe "expression" $ do - describe "basic" $ basicExpressionTests - describe "do statements" $ doStatementTests - describe "alignment" $ alignmentTests - describe "regression" $ regressionTests - -typeSignatureTests :: Spec -typeSignatureTests = do - it "simple001" $ roundTripEqual $ - [text| - func :: a -> a - |] - it "long typeVar" $ roundTripEqual $ - [text| - func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - |] - it "keep linebreak mode" $ roundTripEqual $ - [text| - func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - |] - it "simple parens 1" $ roundTripEqual $ - [text| - func :: ((a)) - |] - it "simple parens 2" $ roundTripEqual $ - [text| - func :: (a -> a) -> a - |] - it "simple parens 3" $ roundTripEqual $ - [text| - func :: a -> (a -> a) - |] - it "did anyone say parentheses?" $ roundTripEqual $ - [text| - func :: (((((((((()))))))))) - |] - before_ pending $ it "give me more!" $ roundTripEqual $ - -- current output is.. funny. wonder if that can/needs to be improved.. - [text| - func :: ((((((((((((((((((((((((((((((((((((((((((())))))))))))))))))))))))))))))))))))))))))) - |] - it "unit" $ roundTripEqual $ - [text| - func :: () - |] - -- ################################################################## -- - -- ################################################################## -- - -- ################################################################## -- - it "paren'd func 1" $ roundTripEqual $ - [text| - func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - ) - |] - it "paren'd func 2" $ roundTripEqual $ - [text| - func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) - |] - it "paren'd func 3" $ roundTripEqual $ - [text| - func - :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) - -> lakjsdlkjasldkj - |] - it "paren'd func 4" $ roundTripEqual $ - [text| - func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> lakjsdlkjasldkj - |] - it "paren'd func 5" $ roundTripEqual $ - [text| - func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) - |] - -- ################################################################## -- - -- ################################################################## -- - -- ################################################################## -- - it "type application 1" $ roundTripEqual $ - [text| - func :: asd -> Either a b - |] - it "type application 2" $ roundTripEqual $ - [text| - func - :: asd - -> Either - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - |] - it "type application 3" $ roundTripEqual $ - [text| - func - :: asd - -> Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - |] - it "type application 4" $ roundTripEqual $ - [text| - func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd - |] - it "type application 5" $ roundTripEqual $ - [text| - func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) - |] - it "type application 6" $ roundTripEqual $ - [text| - func - :: Trither - asd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - |] - it "type application paren 1" $ roundTripEqual $ - [text| - func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - |] - it "type application paren 2" $ roundTripEqual $ - [text| - func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - |] - it "type application paren 3" $ roundTripEqual $ - [text| - func - :: ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd - |] - -- ################################################################## -- - -- ################################################################## -- - -- ################################################################## -- - it "list simple" $ roundTripEqual $ - [text| - func :: [a -> b] - |] - it "list func" $ roundTripEqual $ - [text| - func - :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ] - |] - it "list paren" $ roundTripEqual $ - [text| - func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] - |] - -- ################################################################## -- - -- ################################################################## -- - -- ################################################################## -- - it "tuple type 1" $ roundTripEqual $ - [text| - func :: (a, b, c) - |] - it "tuple type 2" $ roundTripEqual $ - [text| - func :: ((a, b, c), (a, b, c), (a, b, c)) - |] - it "tuple type long" $ roundTripEqual $ - [text| - func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - |] - it "tuple type nested" $ roundTripEqual $ - [text| - func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) - |] - it "tuple type function" $ roundTripEqual $ - [text| - func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] - |] - -- ################################################################## -- - -- ################################################################## -- - -- ################################################################## -- - before_ pending $ it "type operator stuff" $ roundTripEqual $ - [text| - test050 :: a :+: b - test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - |] - -- ################################################################## -- - -- ################################################################## -- - -- ################################################################## -- - it "forall oneliner" $ roundTripEqual $ - [text| - {-# LANGUAGE ScopedTypeVariables #-} - --this comment is necessary for whatever reason.. - func :: forall (a :: *) b . a -> b - |] - it "language pragma issue" $ roundTripEqual $ - [text| - {-# LANGUAGE ScopedTypeVariables #-} - func :: forall (a :: *) b . a -> b - |] - it "comments 1" $ roundTripEqual $ - [text| - func :: a -> b -- comment - |] - it "comments 2" $ roundTripEqual $ - [text| - funcA :: a -> b -- comment A - funcB :: a -> b -- comment B - |] - before_ pending $ it "comments all" $ roundTripEqual $ - [text| - -- a - func -- b - :: -- c - a -- d - -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j - -- k - |] - -- ################################################################## -- - -- ################################################################## -- - -- ################################################################## -- - it "ImplicitParams 1" $ roundTripEqual $ - [text| - {-# LANGUAGE ImplicitParams #-} - func :: (?asd::Int) -> () - |] - it "ImplicitParams 2" $ roundTripEqual $ - [text| - {-# LANGUAGE ImplicitParams #-} - func - :: ( ?asd - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> () - |] - - - --- some basic testing of different kinds of equations. --- some focus on column layouting for multiple-equation definitions. --- (that part probably is not implemented in any way yet.) -basicEquationTests :: Spec -basicEquationTests = do - it "basic 1" $ roundTripEqual $ - [text| - func x = x - |] - it "infix 1" $ roundTripEqual $ - [text| - x *** y = x - |] - it "symbol prefix" $ roundTripEqual $ - [text| - (***) x y = x - |] - - - -patternTests :: Spec -patternTests = do - it "wildcard" $ roundTripEqual $ - [text| - func _ = x - |] - before_ pending $ it "simple long pattern" $ roundTripEqual $ - [text| - func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - |] - before_ pending $ it "simple multiline pattern" $ roundTripEqual $ - [text| - func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - |] - before_ pending $ it "another multiline pattern" $ roundTripEqual $ - [text| - func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - a - b - = x - |] - it "simple constructor" $ roundTripEqual $ - [text| - func (A a) = a - |] - it "list constructor" $ roundTripEqual $ - [text| - func (x:xr) = x - |] - before_ pending $ it "some other constructor symbol" $ roundTripEqual $ - [text| - func (x:+:xr) = x - |] - -guardTests :: Spec -guardTests = do - it "simple guard" $ roundTripEqual $ - [text| - func | True = x - |] - -basicExpressionTests :: Spec -basicExpressionTests = do - it "var" $ roundTripEqual $ - [text| - func = x - |] - describe "infix op" $ do - it "1" $ roundTripEqual $ - [text| - func = x + x - |] - before_ pending $ it "long" $ roundTripEqual $ - [text| - func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - |] - before_ pending $ it "long keep linemode 1" $ roundTripEqual $ - [text| - func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - |] - before_ pending $ it "long keep linemode 2" $ roundTripEqual $ - [text| - func = mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - |] - it "literals" $ roundTripEqual $ - [text| - func = 1 - func = "abc" - func = 1.1e5 - func = 'x' - func = 981409823458910394810928414192837123987123987123 - |] - it "lambdacase" $ roundTripEqual $ - [text| - {-# LANGUAGE LambdaCase #-} - func = \case - FooBar -> x - Baz -> y - |] - it "lambda" $ roundTripEqual $ - [text| - func = \x -> abc - |] - describe "app" $ do - it "1" $ roundTripEqual $ - [text| - func = klajsdas klajsdas klajsdas - |] - it "2" $ roundTripEqual $ - [text| - func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - |] - it "3" $ roundTripEqual $ - [text| - func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas - lakjsdlajsdljas - lakjsdlajsdljas - |] - describe "sections" $ do - it "left" $ roundTripEqual $ - [text| - func = (1+) - |] - it "right" $ roundTripEqual $ - [text| - func = (+1) - |] - it "left inf" $ roundTripEqual $ - -- TODO: this could be improved.. - [text| - func = (1`abc`) - |] - it "right inf" $ roundTripEqual $ - [text| - func = (`abc`1) - |] - describe "tuples" $ do - it "1" $ roundTripEqual $ - [text| - func = (abc, def) - |] - before_ pending $ it "2" $ roundTripEqual $ - [text| - func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) - |] - - -doStatementTests :: Spec -doStatementTests = do - it "simple" $ roundTripEqual $ - [text| - func = do - stmt - stmt - |] - it "bind" $ roundTripEqual $ - [text| - func = do - x <- stmt - stmt x - |] - it "let" $ roundTripEqual $ - [text| - func = do - let x = 13 - stmt x - |] - return () - -alignmentTests :: Spec -alignmentTests = do - return () - -regressionTests :: Spec -regressionTests = do - it "newlines-comment" $ do - roundTripEqual $ - [text| - func = do - abc <- foo - - --abc - return () - |] - it "parenthesis-around-unit" $ do - roundTripEqual $ - [text| - func = (()) - |] - it "let-defs indentation" $ do - roundTripEqual $ - [text| - func = do - let foo True = True - foo _ = False - return () - |] - it "record update indentation 1" $ do - roundTripEqual $ - [text| - func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - |] - it "record update indentation 2" $ do - roundTripEqual $ - [text| - func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state - , _lstate_indent = _lstate_indent state - } - |] - it "record update indentation 3" $ do - roundTripEqual $ - [text| - func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - |] - it "post-indent comment" $ do - roundTripEqual $ - [text| - func = do - -- abc - -- def - return () - |] - it "post-unindent comment" $ do - roundTripEqual $ - [text| - func = do - do - return () - -- abc - -- def - return () - |] - it "CPP empty comment case" $ do - pendingWith "CPP parsing needs fixing for roundTripEqual" - roundTripEqual $ - [text| - {-# LANGUAGE CPP #-} - module Test where - func = do - #if FOO - let x = 13 - #endif - stmt x - |] - -- really, the following should be handled by forcing the Alt to multiline - -- because there are comments. as long as this is not implemented though, - -- we should ensure the trivial solution works. - it "comment inline placement (temporary)" $ do - roundTripEqual $ - [text| - func - :: Int -- basic indentation amount - -> Int -- currently used width in current line (after indent) - -- used to accurately calc placing of the current-line - -> LayoutDesc - -> Int - |] - it "some indentation thingy" $ do - roundTripEqual $ - [text| - func = - ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj - $ abc - $ def - $ ghi - $ jkl - ) - |] - it "parenthesized operator" $ do - roundTripEqual $ - [text| - buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where - reassoc (v, e, w) = (v, (e, w)) - |] - it "record pattern matching stuff" $ do - roundTripEqual $ - [text| - downloadRepoPackage = case repo of - RepoLocal {..} -> return () - RepoLocal { abc } -> return () - RepoLocal{} -> return () - |] - it "do let comment indentation level problem" $ do - roundTripEqual $ - [text| - 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 () - |] - it "list comprehension comment placement" $ do - roundTripEqual $ - [text| - func = - [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_:_)) <- nosuchFooThing - , gast <- award - ] - |] - it "if-then-else comment placement" $ do - roundTripEqual $ - [text| - func = if x - then if y -- y is important - then foo - else bar - else Nothing - |] - it "qualified infix pattern" $ do - pendingWith "TODO" - roundTripEqual $ - [text| - 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 - |] - it "type signature multiline forcing issue" $ do - roundTripEqual $ - [text| - layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () - |] - it "multiwayif proper indentation" $ do - pendingWith "TODO" - roundTripEqual $ - [text| - 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 - |] - it "nested pattern alignment issue" $ do - roundTripEqual $ - [text| - 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 - |] - it "nested pattern alignment issue" $ do - roundTripEqual $ - [text| - 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 - |] - it "partially overflowing alignment issue" $ do - roundTripEqual $ - [text| - 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)) - ] - |] \ No newline at end of file diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs index fe6d099..afb7a94 100644 --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -12,7 +12,6 @@ import NeatInterpolation import Language.Haskell.Brittany -import IdentityTests import AsymptoticPerfTests @@ -22,5 +21,4 @@ main = hspec $ tests tests :: Spec tests = do - describe "identity roundtrips" $ identityTests describe "asymptotic perf roundtrips" $ asymptoticPerfTest diff --git a/src/Language/Haskell/Brittany/Config/Types.hs b/src/Language/Haskell/Brittany/Config/Types.hs index d64575d..cfae3eb 100644 --- a/src/Language/Haskell/Brittany/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Config/Types.hs @@ -12,6 +12,7 @@ where #include "prelude.inc" import Data.Yaml +import qualified Data.Aeson.Types as Aeson import GHC.Generics import Control.Lens @@ -77,6 +78,13 @@ data ConfigF f = Config } deriving (Generic) +data ErrorHandlingConfigFMaybe = ErrorHandlingConfigMaybe + { _econfm_produceOutputOnErrors :: Maybe (Semigroup.Last Bool) + , _econfm_Werror :: Maybe (Semigroup.Last Bool) + , _econfm_CPPMode :: Maybe (Semigroup.Last CPPMode) + } + deriving (Generic) + -- i wonder if any Show1 stuff could be leveraged. deriving instance Show (DebugConfigF Identity) deriving instance Show (LayoutConfigF Identity) @@ -112,43 +120,88 @@ type DebugConfig = DebugConfigF Identity type LayoutConfig = LayoutConfigF Identity type ErrorHandlingConfig = ErrorHandlingConfigF Identity -instance FromJSON a => FromJSON (Semigroup.Last a) where - parseJSON obj = Semigroup.Last <$> parseJSON obj - {-# INLINE parseJSON #-} -instance ToJSON a => ToJSON (Semigroup.Last a) where - toJSON (Semigroup.Last x) = toJSON x - {-# INLINE toJSON #-} +aesonDecodeOptionsBrittany :: Aeson.Options +aesonDecodeOptionsBrittany = Aeson.defaultOptions + { Aeson.omitNothingFields = True + , Aeson.fieldLabelModifier = dropWhile (=='_') + } -instance FromJSON a => FromJSON (Option a) where - parseJSON obj = Option <$> parseJSON obj - {-# INLINE parseJSON #-} -instance ToJSON a => ToJSON (Option a) where - toJSON (Option x) = toJSON x - {-# INLINE toJSON #-} +-- instance FromJSON a => FromJSON (Semigroup.Last a) where +-- parseJSON obj = Semigroup.Last <$> parseJSON obj +-- {-# INLINE parseJSON #-} +-- instance ToJSON a => ToJSON (Semigroup.Last a) where +-- toJSON (Semigroup.Last x) = toJSON x +-- {-# INLINE toJSON #-} +-- +-- instance FromJSON a => FromJSON (Option a) where +-- parseJSON obj = Option <$> parseJSON obj +-- {-# INLINE parseJSON #-} +-- instance ToJSON a => ToJSON (Option a) where +-- toJSON (Option x) = toJSON x +-- {-# INLINE toJSON #-} -instance FromJSON (DebugConfigF Option) -instance ToJSON (DebugConfigF Option) +#define makeFromJSON(type)\ + instance FromJSON (type) where\ + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany +#define makeToJSON(type)\ + instance ToJSON (type) where\ + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany -instance FromJSON IndentPolicy -instance ToJSON IndentPolicy -instance FromJSON AltChooser -instance ToJSON AltChooser -instance FromJSON ColumnAlignMode -instance ToJSON ColumnAlignMode -instance FromJSON CPPMode -instance ToJSON CPPMode +#define makeFromJSONMaybe(type)\ + instance FromJSON (type Maybe) where\ + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany +#define makeFromJSONOption(type)\ + instance FromJSON (type Option) where\ + parseJSON = fmap (cMap Option) . parseJSON +#define makeToJSONMaybe(type)\ + instance ToJSON (type Maybe) where\ + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany +#define makeToJSONOption(type)\ + instance ToJSON (type Option) where\ + toEncoding = toEncoding . cMap getOption -instance FromJSON (LayoutConfigF Option) -instance ToJSON (LayoutConfigF Option) +makeFromJSON(ErrorHandlingConfigFMaybe) +makeToJSON (ErrorHandlingConfigFMaybe) +deriving instance Show (ErrorHandlingConfigFMaybe) -instance FromJSON (ErrorHandlingConfigF Option) -instance ToJSON (ErrorHandlingConfigF Option) -instance FromJSON (ForwardOptionsF Option) -instance ToJSON (ForwardOptionsF Option) +makeFromJSONOption (DebugConfigF) +makeFromJSONMaybe (DebugConfigF) +makeToJSONOption (DebugConfigF) +makeToJSONMaybe (DebugConfigF) +-- instance FromJSON (DebugConfigF Option) where +-- parseJSON = genericParseJSON aesonDecodeOptionsBrittany +-- instance ToJSON (DebugConfigF Option) where +-- toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany -instance FromJSON (ConfigF Option) -instance ToJSON (ConfigF Option) +makeFromJSON (IndentPolicy) +makeToJSON (IndentPolicy) +makeFromJSON (AltChooser) +makeToJSON (AltChooser) +makeFromJSON (ColumnAlignMode) +makeToJSON (ColumnAlignMode) +makeFromJSON (CPPMode) +makeToJSON (CPPMode) + +makeFromJSONOption (LayoutConfigF) +makeFromJSONMaybe (LayoutConfigF) +makeToJSONOption (LayoutConfigF) +makeToJSONMaybe (LayoutConfigF) + +makeFromJSONOption (ErrorHandlingConfigF) +makeFromJSONMaybe (ErrorHandlingConfigF) +makeToJSONOption (ErrorHandlingConfigF) +makeToJSONMaybe (ErrorHandlingConfigF) + +makeFromJSONOption (ForwardOptionsF) +makeFromJSONMaybe (ForwardOptionsF) +makeToJSONOption (ForwardOptionsF) +makeToJSONMaybe (ForwardOptionsF) + +makeFromJSONOption (ConfigF) +makeFromJSONMaybe (ConfigF) +makeToJSONOption (ConfigF) +makeToJSONMaybe (ConfigF) -- instance Monoid DebugConfig where -- mempty = DebugConfig Nothing Nothing diff --git a/stack.yaml b/stack.yaml index 68b933f..759b08e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,7 +7,7 @@ packages: - . - extra-dep: true location: - commit: 8b721f7e17a20a338432f1d31ef55db5e50b8e8d + commit: b15f1ae585341ea312f712e63f29a0c57fa5f637 git: https://github.com/lspitzner/butcher.git - extra-dep: true location: @@ -17,4 +17,4 @@ packages: location: commit: 85af8e4f34ff013575c9acd9675b495ee7f10180 git: https://github.com/lspitzner/ghc-exactprint.git -resolver: nightly-2016-09-04 +resolver: nightly-2016-12-04