diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Revision history for brittany +## 0.8.0.3 -- September 2017 + +* Support for ghc-8.2.1 +* Bugfixes: + - Fix quadratic performance issue + - Fix special "where" indentation with indentAmount /= 2 + - Fix negative literals in patterns + - Support type applications +* Accept `-h` for `--help` and improve help layouting (via butcher-1.1.0.2) +* Add continuous integration via travis (cabal, cabal-new, stack) + (brittle due compilation time limit) +* Reduce compilation memory usage a bit + ## 0.8.0.2 -- August 2017 * Add library interface, to be used by `haskell-ide-engine`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# brittany +# brittany [![Hackage version](https://img.shields.io/hackage/v/brittany.svg?label=Hackage)](https://hackage.haskell.org/package/brittany) [![Stackage version](https://www.stackage.org/package/brittany/badge/lts?label=Stackage)](https://www.stackage.org/package/brittany) [![Build Status](https://secure.travis-ci.org/lspitzner/brittany.svg?branch=master)](http://travis-ci.org/lspitzner/brittany) haskell source code formatter ![Output sample](https://github.com/lspitzner/brittany/raw/master/brittany-sample.gif) @@ -39,13 +39,13 @@ be detected and the user will get an error); there are other cases where comments are moved slightly; there are also cases where comments result in wonky newline insertion (although this should be a purely aesthetic issue.) -- There is an **open performance issue on large inputs** (due to an - accidentally quadratic sub-algorithm); noticable for inputs with >1k loc. +- ~~There is an **open performance issue on large inputs** (due to an + accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.~~ + (fixed in `0.8.0.3`) # Other usage notes -- Requires `GHC-8.0.*`; support for 8.2 is on the list, but I haven't even - looked at how much the `GHC` API changes. +- Supports GHC versions `8.0.*` and `8.2.*`. - config (file) documentation is lacking. - some config values can not be configured via commandline yet. - uses/creates user config file in `~/.brittany/config.yaml`; @@ -55,32 +55,32 @@ - via `cabal` "old-build" - ~~~~.sh - # optionally: - # mkdir brittany - # cd brittany - # cabal sandbox init - cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_0 - ~~~~ + ~~~~.sh + # optionally: + # mkdir brittany + # cd brittany + # cabal sandbox init + cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_0 + ~~~~ - via `cabal new-build` - ~~~~.sh - cabal unpack brittany - cd brittany-0.8.0.2 - # cabal new-configure -w $PATH_TO_GHC_8_0 - cabal new-build exe:brittany - # and it should be safe to just copy the executable, e.g. - cp `./find dist-newstyle/build/ -type f -name brittany` $HOME/.cabal/bin/ - ~~~~ + ~~~~.sh + cabal unpack brittany + cd brittany-0.8.0.2 + # cabal new-configure -w $PATH_TO_GHC_8_0 + cabal new-build exe:brittany + # and it should be safe to just copy the executable, e.g. + cp `./find dist-newstyle/build/ -type f -name brittany` $HOME/.cabal/bin/ + ~~~~ - via `stack` - ~~~~.sh - git clone https://github.com/lspitzner/brittany.git - cd brittany - stack install - ~~~~ + ~~~~.sh + git clone https://github.com/lspitzner/brittany.git + cd brittany + stack install + ~~~~ # Usage @@ -92,22 +92,22 @@ by default, i.e. to add something like this to your `~/.brittany/config.yaml` (execute `brittany` once to create default): - ~~~~ - conf_forward: - options_ghc: - - -XLambdaCase - - -XMultiWayIf - - -XGADTs - - -XPatternGuards - - -XViewPatterns - - -XRecursiveDo - - -XTupleSections - - -XExplicitForAll - - -XImplicitParams - - -XQuasiQuotes - - -XTemplateHaskell - - -XBangPatterns - ~~~~ + ~~~~ + conf_forward: + options_ghc: + - -XLambdaCase + - -XMultiWayIf + - -XGADTs + - -XPatternGuards + - -XViewPatterns + - -XRecursiveDo + - -XTupleSections + - -XExplicitForAll + - -XImplicitParams + - -XQuasiQuotes + - -XTemplateHaskell + - -XBangPatterns + ~~~~ # Implementation/High-level Documentation diff --git a/brittany.cabal b/brittany.cabal --- a/brittany.cabal +++ b/brittany.cabal @@ -1,11 +1,11 @@ name: brittany -version: 0.8.0.2 +version: 0.8.0.3 synopsis: Haskell source code formatter description: { - See - + See . + . If you are interested in the implementation, have a look at ; - + . The implementation is documented in more detail . } license: AGPL-3 @@ -23,6 +23,9 @@ README.md doc/implementation/*.md } +extra-source-files: { + src-literatetests/tests.blt +} source-repository head { type: git @@ -51,10 +54,12 @@ Language.Haskell.Brittany 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.Config Language.Haskell.Brittany.Internal.Config.Types + Language.Haskell.Brittany.Internal.Config.Types.Instances Paths_brittany } other-modules: { @@ -77,15 +82,14 @@ -Wall -j -fno-warn-unused-imports - -fno-warn-orphans -fno-warn-redundant-constraints } if flag(brittany-dev) { ghc-options: -O0 -Werror -fobject-code } build-depends: - { base >=4.9 && <4.10 - , ghc >=8.0.1 && <8.1 + { base >=4.9 && <4.11 + , ghc >=8.0.1 && <8.3 , ghc-paths >=0.1.0.9 && <0.2 , ghc-exactprint >=0.5.3.0 && <0.6 , transformers >=0.5.2.0 && <0.6 @@ -93,7 +97,7 @@ , mtl >=2.2.1 && <2.3 , text >=1.2 && <1.3 , multistate >=0.7.1.1 && <0.8 - , syb >=0.6 && <0.7 + , syb >=0.6 && <0.8 , neat-interpolation >=0.3.2 && <0.4 , data-tree-print , pretty >=1.1.3.3 && <1.2 @@ -102,7 +106,7 @@ , butcher >=1.1.0.0 && <1.2 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 - , extra >=1.4.10 && <1.6 + , extra >=1.4.10 && <1.7 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 , monad-memo >=0.4.1 && <0.5 @@ -113,7 +117,7 @@ , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1 - , ghc-boot-th >=8.0.1 && <8.1 + , ghc-boot-th >=8.0.1 && <8.3 } default-extensions: { CPP @@ -202,7 +206,6 @@ -j -fno-spec-constr -fno-warn-unused-imports - -fno-warn-orphans -fno-warn-redundant-constraints -rtsopts -with-rtsopts "-M2G" @@ -282,7 +285,6 @@ -Wall -j -fno-warn-unused-imports - -fno-warn-orphans -rtsopts -with-rtsopts "-M2G" } @@ -356,7 +358,6 @@ -Wall -j -fno-warn-unused-imports - -fno-warn-orphans -rtsopts -with-rtsopts "-M2G" } @@ -396,7 +397,6 @@ -Wall -j -fno-warn-unused-imports - -fno-warn-orphans -rtsopts -with-rtsopts "-M2G" } diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -90,6 +90,7 @@ ] ] + mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () mainCmdParser helpDesc = do addCmdSynopsis "haskell source pretty printer" @@ -99,7 +100,7 @@ addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "" ["help"] mempty + printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "path to input haskell source file") @@ -116,10 +117,10 @@ desc <- peekCmdDesc addCmdImpl $ void $ do when printLicense $ do - liftIO $ print licenseDoc + print licenseDoc System.Exit.exitSuccess when printVersion $ do - liftIO $ do + do putStrLn $ "brittany version " ++ showVersion version putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner" putStrLn $ "There is NO WARRANTY, to the extent permitted by law." @@ -132,127 +133,146 @@ return Nothing [x] -> return $ Just x _ -> do - liftIO $ putStrErrLn $ "more than one input, aborting" - System.Exit.exitWith (System.Exit.ExitFailure 50) - outputPath <- case outputPaths of + putStrErrLn $ "more than one input, aborting" + System.Exit.exitWith (System.Exit.ExitFailure 51) + outputPathM <- case outputPaths of [] -> do return Nothing [x] -> return $ Just x _ -> do - liftIO $ putStrErrLn $ "more than one output, aborting" - System.Exit.exitWith (System.Exit.ExitFailure 50) + putStrErrLn $ "more than one output, aborting" + System.Exit.exitWith (System.Exit.ExitFailure 52) config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50) + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do trace (showConfigYaml config) $ return () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - liftIO $ do - -- 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 - -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = 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 - putStrErrLn - $ "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 <- case inputPathM of - Nothing -> do - -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s then "-- BRITTANY_INCLUDE_HACK " ++ s else s - let hackTransform = - if hackAroundIncludes && not exactprintOnly then List.unlines . fmap hackF . List.lines else id - inputString <- System.IO.hGetContents System.IO.stdin - parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString) - Just p -> parseModule ghcOptions p cppCheckFunc - case parseResult of - Left left -> do - putStrErrLn "parse error:" - printErr left - System.Exit.exitWith (System.Exit.ExitFailure 60) - Right (anns, parsedSource, hasCPP) -> do - when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - (errsWarns, outLText) <- do - if exactprintOnly - then do - pure ([], TextL.pack $ ExactPrint.exactPrint parsedSource anns) - else do - let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config anns parsedSource - else pPrintModuleAndCheck config anns parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s - pure $ if hackAroundIncludes - then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) - else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - when (not $ null errsWarns) $ do - let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{}:_) -> do - putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." - (ErrorInput str:_) -> do - putStrErrLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{}:_) -> do - putStrErrLn $ "ERROR: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast -> do - putStrErrLn str - when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do - putStrErrLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - warns@(LayoutWarning{}:_) -> do - putStrErrLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putStrErrLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{}:_) -> do - putStrErrLn - $ "Error: detected unprocessed comments." - ++ " The transformation output will most likely" - ++ " not contain certain of the comments" - ++ " present in the input haskell source file." - putStrErrLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putStrErrLn str - _ -> error "cannot happen (TM)" - [] -> error "cannot happen" - -- TODO: don't output anything when there are errors unless user - -- adds some override? - let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack - shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) + eitherErrSucc <- coreIO putStrErrLn config suppressOutput inputPathM outputPathM + case eitherErrSucc of + Left errNo -> System.Exit.exitWith (System.Exit.ExitFailure errNo) + Right () -> pure () - when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of - Nothing -> TextL.IO.putStr $ outLText - Just p -> TextL.IO.writeFile p $ outLText - when hasErrors $ System.Exit.exitWith (System.Exit.ExitFailure 70) +-- | 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. + -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. + -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. + -> IO (Either Int ()) -- ^ Either an errorNo, or success. +coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEitherT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> EitherT.EitherT 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 + -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = 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 <- case inputPathM of + Nothing -> do + -- TODO: refactor this hack to not be mixed into parsing logic + let hackF s = if "#include" `isPrefixOf` s then "-- BRITTANY_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 + liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString) + Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc + case parseResult of + Left left -> do + putErrorLn "parse error:" + putErrorLn $ show left + EitherT.left 60 + Right (anns, parsedSource, hasCPP) -> do + when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + (errsWarns, outLText) <- do + if exactprintOnly + then do + pure ([], TextL.pack $ ExactPrint.exactPrint parsedSource anns) + else do + let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule config anns parsedSource + else liftIO $ pPrintModuleAndCheck config anns parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_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 + 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 $ "ERROR: encountered unknown syntactical constructs:" + uns `forM_` \case + ErrorUnknownNode str ast -> do + putErrorLn str + when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + 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 certain 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)" + [] -> 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 hasErrors || outputOnErrs) + + when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of + Nothing -> liftIO $ TextL.IO.putStr $ outLText + Just p -> liftIO $ TextL.IO.writeFile p $ outLText + + when hasErrors $ EitherT.left 70 where addTraceSep conf = if or @@ -268,6 +288,7 @@ ] then trace "----" else id + readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt new file mode 100644 --- /dev/null +++ b/src-literatetests/tests.blt @@ -0,0 +1,1080 @@ + +############################################################################### +############################################################################### +############################################################################### +#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 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) + + + +############################################################################### +############################################################################### +############################################################################### +#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 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 +{-# 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 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 a + +foo = + let a = b@1 + cccc = () + in foo + +#test issue 48 b + +{-# LANGUAGE TypeApplications #-} +foo = + let a = b @1 + cccc = () + in foo + + +############################################################################### +############################################################################### +############################################################################### +#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/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -73,7 +73,7 @@ then "-- BRITTANY_INCLUDE_HACK " ++ s else s let hackTransform = if hackAroundIncludes - then List.unlines . fmap hackF . List.lines + then List.intercalate "\n" . fmap hackF . lines' else id let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags then case cppMode of @@ -101,7 +101,12 @@ let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes - then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) + 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 @@ -115,6 +120,7 @@ if hasErrors then left $ 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 @@ -134,6 +140,7 @@ $ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ do traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns @@ -260,7 +267,19 @@ anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns in (anns', post) MultiRWSS.withMultiReader anns' $ processDefault emptyModule - decls `forM_` ppDecl + decls `forM_` \decl -> do + filteredAnns <- mAsk <&> \annMap -> + Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap + + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns + + config <- mAsk + + MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns :+: HNil + ppDecl decl let finalComments = filter ( fst .> \case ExactPrint.Types.AnnComment{} -> True @@ -285,7 +304,7 @@ ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY) _ -> return () -withTransformedAnns :: Data ast => ast -> PPM () -> PPM () +withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () withTransformedAnns ast m = do -- TODO: implement `local` for MultiReader/MultiRWS readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR @@ -299,13 +318,13 @@ in annsBalanced -ppDecl :: LHsDecl RdrName -> PPM () +ppDecl :: LHsDecl RdrName -> PPMLocal () ppDecl d@(L loc decl) = case decl of SigD sig -> -- trace (_sigHead sig) $ withTransformedAnns d $ do -- runLayouter $ Old.layoutSig (L loc sig) briDoc <- briDocMToPPM $ layoutSig (L loc sig) - layoutBriDoc d briDoc + layoutBriDoc briDoc ValD bind -> -- trace (_bindHead bind) $ withTransformedAnns d $ do -- Old.layoutBind (L loc bind) @@ -314,8 +333,8 @@ case eitherNode of Left ns -> docLines $ return <$> ns Right n -> return n - layoutBriDoc d briDoc - _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d + layoutBriDoc briDoc + _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc _sigHead :: Sig RdrName -> String _sigHead = \case @@ -331,8 +350,8 @@ -layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () -layoutBriDoc ast briDoc = do +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. @@ -368,12 +387,7 @@ -- return simpl anns :: ExactPrint.Types.Anns <- mAsk - let filteredAnns = filterAnns ast anns - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns - let state = LayoutState { _lstate_baseYs = [0] , _lstate_curYOrAddNewline = Right 0 -- important that we use left here @@ -382,10 +396,9 @@ -- thing properly. , _lstate_indLevels = [0] , _lstate_indLevelLinger = 0 - , _lstate_comments = filteredAnns + , _lstate_comments = anns , _lstate_commentCol = Nothing , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -152,8 +152,7 @@ BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let allowMTEL = not (_lstate_inhibitMTEL state) - && Data.Either.isRight (_lstate_curYOrAddNewline state) + let allowMTEL = Data.Either.isRight (_lstate_curYOrAddNewline state) mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -184,7 +183,7 @@ layoutBriDocM bd BDAnnotationKW annKey keyword bd -> do layoutBriDocM bd - mAnn <- do + mComments <- do state <- mGet let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m @@ -204,11 +203,12 @@ annKey m } - return $ [ comments | not $ null comments ] + return $ nonEmpty comments _ -> return Nothing - forM_ mAnn - $ mapM_ - $ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + case mComments of + Nothing -> pure () + Just comments -> do + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do -- evil hack for CPP: case comment of @@ -221,10 +221,10 @@ -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd - mAnn <- do + mComments <- do state <- mGet let m = _lstate_comments state - let mAnn = extractAllComments <$> Map.lookup annKey m + let mComments = nonEmpty =<< extractAllComments <$> Map.lookup annKey m mSet $ state { _lstate_comments = Map.adjust ( \ann -> ann { ExactPrint.annFollowingComments = [] @@ -235,10 +235,11 @@ annKey m } - return mAnn - forM_ mAnn - $ mapM_ - $ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + return mComments + case mComments of + Nothing -> pure () + Just comments -> do + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do -- evil hack for CPP: case comment of @@ -252,22 +253,6 @@ BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd - BDProhibitMTEL bd -> do - -- set flag to True for this child, but disable afterwards. - -- two hard aspects - -- 1) nesting should be allowed. this means that resetting at the end must - -- not indiscriminantely set to False, but take into account the - -- previous value - -- 2) nonetheless, newlines cancel inhibition. this means that if we ever - -- find the flag set to False afterwards, we must not return it to - -- the previous value, which might be True in the case of testing; it - -- must remain False. - state <- mGet - mSet $ state { _lstate_inhibitMTEL = True } - layoutBriDocM bd - state' <- mGet - when (_lstate_inhibitMTEL state') $ do - mSet $ state' { _lstate_inhibitMTEL = _lstate_inhibitMTEL state } BDDebug s bd -> do mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" layoutBriDocM bd @@ -302,7 +287,6 @@ return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x BDLines [] -> error "briDocLineLength BDLines []" BDEnsureIndent _ bd -> rec bd - BDProhibitMTEL bd -> rec bd BDSetParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd BDNonBottomSpacing bd -> rec bd @@ -328,6 +312,7 @@ BDForceMultiline _ -> True BDForceSingleline bd -> rec bd BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t | [_] <- Text.lines t -> False BDExternal _ _ _ _ -> True BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd @@ -336,7 +321,6 @@ BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" BDEnsureIndent _ bd -> rec bd - BDProhibitMTEL bd -> rec bd BDSetParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd BDNonBottomSpacing bd -> rec bd @@ -344,6 +328,7 @@ 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 @@ -385,7 +370,9 @@ Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} - fmap colAggregation $ transpose $ Foldable.toList colss + fmap colAggregation $ transpose $ Foldable.toList + -- $ trace ("colss=" ++ show colss ++ " for" ++ take 100 (show $ briDocToDoc $ head bridocs)) + colss (_, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols counter count l = if List.last posXs + List.last l <= colMax then count + 1 @@ -404,10 +391,54 @@ mergeBriDocsW lastInfo (bd:bdr) = do info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW - (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) + -- (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 ColRecUpdate _) -> 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 @@ -483,9 +514,15 @@ alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack curX <- do state <- mGet - return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe - 0 - (_lstate_addSepSpace state) + -- 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 -- tellDebugMess $ show curX let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols @@ -508,6 +545,8 @@ offsets = (subtract curX) <$> posXs fixed = offsets <&> fromIntegral .> (*factor) .> truncate _ -> posXs + -- tellDebugMess $ "maxCols = " ++ show maxCols + -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do layoutWriteEnsureAbsoluteN destX processInfo m (snd x) diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -146,7 +146,6 @@ state <- mGet mSet $ state { _lstate_curYOrAddNewline = Right 1 , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_inhibitMTEL = False } -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m @@ -185,28 +184,23 @@ layoutMoveToCommentPos y x = do traceLocal ("layoutMoveToCommentPos", y, x) state <- mGet - if Data.Maybe.isJust (_lstate_commentCol state) - then do - 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 $ case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - } - else do - 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 y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state - } + mSet state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right{} -> Right y + , _lstate_addSepSpace = if Data.Maybe.isJust (_lstate_commentCol state) + then Just $ case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else Just $ 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 + } + -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline :: ( MonadMultiWriter Text.Builder.Builder m @@ -222,7 +216,6 @@ Left{} -> Right 1 Right i -> Right (i + 1) , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False } layoutWriteEnsureNewlineBlock @@ -239,7 +232,6 @@ Left{} -> Right 1 Right i -> Right $ max 1 i , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_inhibitMTEL = False , _lstate_commentCol = Nothing } @@ -498,6 +490,7 @@ 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 @@ -531,6 +524,7 @@ layoutWriteAppendSpaces y layoutWriteAppendMultiline $ 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 ..". diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -27,6 +27,7 @@ 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 ) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -185,92 +185,6 @@ mempty = gmempty mappend = gmappend -aesonDecodeOptionsBrittany :: Aeson.Options -aesonDecodeOptionsBrittany = Aeson.defaultOptions - { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (=='_') - } - -#define makeFromJSON(type)\ - instance FromJSON (type) where\ - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany -#define makeToJSON(type)\ - instance ToJSON (type) where\ - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany;\ - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -#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\ - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany;\ - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany -#define makeToJSONOption(type)\ - instance ToJSON (type Option) where\ - toJSON = toJSON . cMap getOption;\ - toEncoding = toEncoding . cMap getOption - - -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" - 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 data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more -- than old indentation + amount diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -0,0 +1,127 @@ +{-# 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" + 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 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -5,6 +5,8 @@ , parseModuleFromString , commentAnnFixTransform , commentAnnFixTransformGlob + , extractToplevelAnns + , foldedAnnKeys ) where @@ -14,7 +16,6 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Utils import DynFlags ( getDynFlags ) @@ -36,6 +37,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Data.Generics as SYB +-- import Data.Generics.Schemes @@ -109,11 +111,9 @@ 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.ext2Q` (\(L a b) -> f1 a b) - where - f1 b c = (const Seq.empty `SYB.extQ` f2 c) b - f2 c l = Seq.singleton (l, ExactPrint.mkAnnKey (L l c)) - -- i wonder if there is a way to avoid re-constructing the L above.. + 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 @@ -209,3 +209,40 @@ 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 RdrName) + -> ExactPrint.Anns + -> Map ExactPrint.AnnKey ExactPrint.Anns +extractToplevelAnns lmod anns = output + where + (L _ (HsModule _ _ _ ldecls _ _)) = lmod + declMap :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap = Map.unions $ ldecls <&> \ldecl -> + Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) + 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 <- SYB.gmapQi 0 SYB.cast x + ] + ) + ast + where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -67,6 +67,7 @@ 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 ) @@ -81,8 +82,10 @@ import DataTreePrint +import Data.HList.HList + processDefault :: ( ExactPrint.Annotate.Annotate ast , MonadMultiWriter Text.Builder.Builder m @@ -222,20 +225,6 @@ _ -> [] ) -foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey -foldedAnnKeys ast = everything - Set.union - ( \x -> maybe Set.empty - Set.singleton - [ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x - | locTyCon == typeRepTyCon (typeOf x) - , l <- gmapQi 0 cast x - ] - ) - ast - where - locTyCon = typeRepTyCon (typeOf (L () ())) - filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns ast anns = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns @@ -614,7 +603,7 @@ spacifyDocs [] = [] spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] -briDocMToPPM :: ToBriDocM a -> PPM a +briDocMToPPM :: ToBriDocM a -> PPMLocal a briDocMToPPM m = do readers <- MultiRWSS.mGetRawR let ((x, errs), debugs) = diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -43,7 +43,11 @@ layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + TypeSig names (HsWC _ (HsIB _ typ _)) -> docWrapNode lsig $ do +#else /* ghc-8.0 */ TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do +#endif nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ @@ -215,12 +219,18 @@ patPartParWrap = case mPatDoc of Nothing -> id Just patDoc -> docPar (return patDoc) - whereIndent <- - mAsk + whereIndent <- do + shouldSpecial <- mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack - .> Bool.bool BrIndentRegular (BrIndentSpecial 1) + 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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -94,7 +94,11 @@ ] HsLam{} -> unknownNodeError "HsLam too complex" lexpr +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do +#else /* ghc-8.0 */ HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do +#endif binderDoc <- docLit $ Text.pack "->" funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar @@ -167,7 +171,11 @@ expDoc1 expDoc2 ] +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsAppType exp1 (HsWC _ ty1) -> do +#else /* ghc-8.0 */ HsAppType exp1 (HsWC _ _ ty1) -> do +#endif t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 docAlt @@ -791,7 +799,11 @@ ] in [line1] ++ lineR ++ [lineN]) ] +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do +#else /* ghc-8.0 */ ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do +#endif expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 docSeq @@ -890,9 +902,11 @@ briDocByExactInlineOnly "HsTickPragma{}" lexpr EWildPat{} -> do docLit $ Text.pack "_" - EAsPat{} -> do - -- TODO - briDocByExactInlineOnly "EAsPat{}" lexpr + EAsPat asName asExpr -> do + docSeq + [ docLit $ (lrdrNameToText asName) <> Text.pack "@" + , layoutExpr asExpr + ] EViewPat{} -> do -- TODO briDocByExactInlineOnly "EViewPat{}" lexpr @@ -902,9 +916,43 @@ HsWrap{} -> do -- TODO briDocByExactInlineOnly "HsWrap{}" lexpr +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsConLikeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsWrap{}" lexpr + ExplicitSum{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitSum{}" lexpr +#endif + +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ litBriDoc :: HsLit -> 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 (SourceText t) _i -> 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 t _) _type -> BDFLit $ Text.pack t + HsFloatPrim (FL t _) -> BDFLit $ Text.pack t + HsDoublePrim (FL t _) -> BDFLit $ Text.pack t + _ -> error "litBriDoc: literal with no SourceText" + +overLitValBriDoc :: OverLitVal -> BriDocFInt +overLitValBriDoc = \case + HsIntegral (SourceText t) _ -> BDFLit $ Text.pack t + HsFractional (FL t _) -> BDFLit $ Text.pack t + HsIsString (SourceText t) _ -> BDFLit $ Text.pack t + _ -> error "overLitValBriDoc: literal with no SourceText" +#else +litBriDoc :: HsLit -> BriDocFInt +litBriDoc = \case HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString @@ -924,3 +972,4 @@ HsIntegral t _ -> BDFLit $ Text.pack t HsFractional (FL t _) -> BDFLit $ Text.pack t HsIsString t _ -> BDFLit $ Text.pack t +#endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -102,7 +102,11 @@ Unboxed -> wrapPatListy args "(#" "#)" AsPat asName asPat -> do wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do +#else /* ghc-8.0 */ SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do +#endif patDocs <- layoutPat pat1 tyDoc <- docSharedWrapper layoutType ty1 case Seq.viewr patDocs of @@ -127,8 +131,12 @@ wrapPatPrepend pat1 (docLit $ Text.pack "!") LazyPat pat1 -> do wrapPatPrepend pat1 (docLit $ Text.pack "~") - NPat llit@(L _ (OverLit olit _ _ _)) _ _ _ -> do - fmap Seq.singleton $ docWrapNode llit $ allocateNode $ overLitValBriDoc olit + NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit + negDoc <- docLit $ Text.pack "-" + pure $ case mNegative of + Just{} -> Seq.fromList [negDoc, litDoc] + Nothing -> Seq.singleton litDoc -- if MIN_VERSION_ghc(8,0,0) -- VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -19,6 +19,7 @@ import HsSyn import Name import Outputable ( ftext, showSDocUnsafe ) +import BasicTypes import DataTreePrint @@ -27,7 +28,11 @@ layoutType :: ToBriDoc HsType layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsTyVar _ name -> do +#else /* ghc-8.0 */ HsTyVar name -> do +#endif t <- lrdrNameToTextAnn name docWrapNode name $ docLit t HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do @@ -463,7 +468,11 @@ -- } -- , _layouter_ast = ltype -- } +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsIParamTy (L _ (HsIPName ipName)) typ1 -> do +#else /* ghc-8.0 */ HsIParamTy (HsIPName ipName) typ1 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -571,12 +580,16 @@ -- , _layouter_ast = ltype -- } HsSpliceTy{} -> -- TODO - briDocByExactInlineOnly "" ltype + briDocByExactInlineOnly "HsSpliceTy{}" ltype HsDocTy{} -> -- TODO - briDocByExactInlineOnly "" ltype + briDocByExactInlineOnly "HsDocTy{}" ltype HsRecTy{} -> -- TODO - briDocByExactInlineOnly "" ltype + briDocByExactInlineOnly "HsRecTy{}" ltype +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsExplicitListTy _ _ typs -> do +#else /* ghc-8.0 */ HsExplicitListTy _ typs -> do +#endif typDocs <- docSharedWrapper layoutType `mapM` typs docAlt [ docSeq @@ -586,10 +599,24 @@ -- TODO ] HsExplicitTupleTy{} -> -- TODO - briDocByExactInlineOnly "" ltype - HsTyLit{} -> -- TODO - briDocByExactInlineOnly "" ltype + briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype + HsTyLit lit -> case lit of +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + 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" +#else /* ghc-8.0 */ + HsNumTy srctext _ -> docLit $ Text.pack srctext + HsStrTy srctext _ -> docLit $ Text.pack srctext +#endif HsCoreTy{} -> -- TODO - briDocByExactInlineOnly "" ltype + briDocByExactInlineOnly "HsCoreTy{}" ltype HsWildCardTy _ -> docLit $ Text.pack "_" +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsSumTy{} -> -- TODO + briDocByExactInlineOnly "HsSumTy{}" ltype +#endif diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,68 +1,378 @@ -module Language.Haskell.Brittany.Internal.Prelude +module Language.Haskell.Brittany.Internal.Prelude (module E) where -import Prelude -import qualified Data.Strict.Maybe as Strict -import Debug.Trace -import Control.Monad -import System.IO +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 Control.DeepSeq ( NFData, force ) -import Control.Exception.Base ( evaluate ) +import Data.Map as E ( Map ) +import Data.Set as E ( Set ) -import Control.Applicative +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 + ) -instance Applicative Strict.Maybe where - pure = Strict.Just - Strict.Just f <*> Strict.Just x = Strict.Just (f x) - _ <*> _ = Strict.Nothing +import Data.Foldable as E ( foldl' + , foldr' + , fold + , asum + ) -instance Monad Strict.Maybe where - return = Strict.Just - Strict.Nothing >>= _ = Strict.Nothing - Strict.Just x >>= f = f x +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 + ) -instance Alternative Strict.Maybe where - empty = Strict.Nothing - x <|> Strict.Nothing = x - _ <|> x = x +import Data.List.NonEmpty as E ( NonEmpty(..) + , nonEmpty + ) -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 +import Data.Tuple as E ( swap + ) -(<&!>) :: Monad m => m a -> (a -> b) -> m b -(<&!>) = flip (<$!>) +import Data.Char as E ( ord + , chr + ) -putStrErrLn :: String -> IO () -putStrErrLn s = hPutStrLn stderr s +import Data.Maybe as E ( fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + ) -printErr :: Show a => a -> IO () -printErr = putStrErrLn . show +import Data.Word as E ( Word32 + ) -errorIf :: Bool -> a -> a -errorIf False = id -errorIf True = error "errorIf" +import Data.Ord as E ( comparing + , Down (..) + ) -errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id -errorIfNote (Just x) = error x +import Data.Either as E ( either + ) -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = flip fmap -infixl 4 <&> +import Data.Ratio as E ( Ratio + , (%) + , numerator + , denominator + ) -(.>) :: (a -> b) -> (b -> c) -> (a -> c) -f .> g = g . f -infixl 9 .> +import Text.Read as E ( readMaybe + ) -evaluateDeep :: NFData a => a -> IO a -evaluateDeep = evaluate . force +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 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(..) + -- , 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 + ) + diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -0,0 +1,69 @@ +{-# 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 + +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 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -79,8 +79,8 @@ $ rec $ briDoc where - -- this funtion is exponential by nature and cannot be improved in any - -- way i can think of, and if tried. (stupid StableNames.) + -- 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 @@ -334,8 +334,6 @@ BDFNonBottomSpacing bd -> rec bd BDFSetParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd - BDFProhibitMTEL bd -> - reWrap . BDFProhibitMTEL <$> rec bd BDFDebug s bd -> do acp :: AltCurPos <- mGet tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp @@ -490,7 +488,6 @@ BDFForceParSpacing bd -> do mVs <- rec bd return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFProhibitMTEL bd -> rec bd BDFDebug s bd -> do r <- rec bd tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r @@ -593,7 +590,7 @@ -- 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 simly using a Set). + -- 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 @@ -758,7 +755,6 @@ BDFForceParSpacing bd -> do mVs <- preFilterLimit <$> rec bd return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFProhibitMTEL bd -> rec bd BDFDebug s bd -> do r <- rec bd tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -129,7 +129,6 @@ BDAnnotationKW{} -> Nothing BDAnnotationRest{} -> Nothing BDEnsureIndent{} -> Nothing - BDProhibitMTEL{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing BDDebug{} -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -28,8 +28,16 @@ -type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] a +type PPM = MultiRWSS.MultiRWS + '[Map ExactPrint.AnnKey ExactPrint.Anns, Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] +type PPMLocal = MultiRWSS.MultiRWS + '[Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] + data LayoutState = LayoutState { _lstate_baseYs :: [Int] -- ^ stack of number of current indentation columns @@ -62,17 +70,10 @@ , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone -- writes (any non-spaces) in the -- current line. - , _lstate_inhibitMTEL :: Bool - -- ^ inhibit move-to-exact-location. - -- normally, processing a node's annotation involves moving to the exact - -- (vertical) location of the node. this ensures that newlines in the - -- input are retained in the output. - -- While this flag is on, this behaviour will be disabled. - -- The flag is automatically turned off when inserting any kind of - -- newline. -- , _lstate_isNewline :: NewLineState -- -- captures if the layouter currently is in a new line, i.e. if the -- -- current line only contains (indentation) spaces. + -- this is mostly superseeded by curYOrAddNewline, iirc. } lstate_baseY :: LayoutState -> Int @@ -91,7 +92,6 @@ ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) - ++ ",inhibitMTEL=" ++ show (_lstate_inhibitMTEL state) ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a @@ -171,7 +171,7 @@ -- expected to have exactly two columns | ColBindStmt | ColDoLet -- the non-indented variant - | ColRecUpdate + | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? | ColListComp | ColList | ColApp @@ -243,11 +243,6 @@ | BDSetParSpacing BriDoc | BDForceParSpacing BriDoc -- pseudo-deprecated - | BDProhibitMTEL BriDoc -- move to exact location - -- TODO: this constructor is deprecated. should - -- still work, but i should probably completely - -- remove it, as i have no proper usecase for - -- it anymore. | BDDebug String BriDoc deriving (Data.Data.Data, Eq, Ord) @@ -289,11 +284,6 @@ | BDFNonBottomSpacing (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f)) - | BDFProhibitMTEL (f (BriDocF f)) -- move to exact location - -- TODO: this constructor is deprecated. should - -- still work, but i should probably completely - -- remove it, as i have no proper usecase for - -- it anymore. | BDFDebug String (f (BriDocF f)) -- deriving instance Data.Data.Data (BriDocF Identity) @@ -327,7 +317,6 @@ uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd uniplate (BDDebug s bd) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int @@ -359,7 +348,6 @@ BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd BDFSetParSpacing bd -> BDSetParSpacing $ rec bd BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered @@ -395,7 +383,6 @@ BDNonBottomSpacing bd -> briDocSeqSpine bd BDSetParSpacing bd -> briDocSeqSpine bd BDForceParSpacing bd -> briDocSeqSpine bd - BDProhibitMTEL bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -23,6 +23,7 @@ , transformDownMay , FirstLastView(..) , splitFirstLast + , lines' ) where @@ -280,3 +281,11 @@ 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 diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -1,164 +1,60 @@ 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.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.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 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 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.Exception.Lens --- import qualified Control.Lens --- import qualified Control.Lens.At --- import qualified Control.Lens.Combinators --- import qualified Control.Lens.Cons --- import qualified Control.Lens.Each --- import qualified Control.Lens.Empty --- import qualified Control.Lens.Equality --- import qualified Control.Lens.Extras --- import qualified Control.Lens.Fold --- import qualified Control.Lens.Getter --- import qualified Control.Lens.Indexed --- import qualified Control.Lens.Internal --- import qualified Control.Lens.Internal.Bazaar --- import qualified Control.Lens.Internal.ByteString --- import qualified Control.Lens.Internal.Coerce --- import qualified Control.Lens.Internal.Context --- import qualified Control.Lens.Internal.Deque --- import qualified Control.Lens.Internal.Exception --- import qualified Control.Lens.Internal.FieldTH --- import qualified Control.Lens.Internal.Fold --- import qualified Control.Lens.Internal.Getter --- import qualified Control.Lens.Internal.Indexed --- import qualified Control.Lens.Internal.Instances --- import qualified Control.Lens.Internal.Iso --- import qualified Control.Lens.Internal.Level --- import qualified Control.Lens.Internal.List --- import qualified Control.Lens.Internal.Magma --- import qualified Control.Lens.Internal.Prism --- import qualified Control.Lens.Internal.PrismTH --- import qualified Control.Lens.Internal.Review --- import qualified Control.Lens.Internal.Setter --- import qualified Control.Lens.Internal.TH --- import qualified Control.Lens.Internal.Zoom --- import qualified Control.Lens.Iso --- import qualified Control.Lens.Lens --- import qualified Control.Lens.Level --- import qualified Control.Lens.Operators --- import qualified Control.Lens.Plated --- import qualified Control.Lens.Prism --- import qualified Control.Lens.Reified --- import qualified Control.Lens.Review --- import qualified Control.Lens.Setter --- import qualified Control.Lens.TH --- import qualified Control.Lens.Traversal --- import qualified Control.Lens.Tuple --- import qualified Control.Lens.Type --- import qualified Control.Lens.Wrapped --- import qualified Control.Lens.Zoom --- import qualified Control.Monad.Error.Lens --- import qualified Control.Parallel.Strategies.Lens --- import qualified Control.Seq.Lens --- import qualified Data.Array.Lens --- import qualified Data.Bits.Lens --- import qualified Data.ByteString.Lazy.Lens --- import qualified Data.ByteString.Lens --- import qualified Data.ByteString.Strict.Lens --- import qualified Data.Complex.Lens --- import qualified Data.Data.Lens --- import qualified Data.Dynamic.Lens --- import qualified Data.HashSet.Lens --- import qualified Data.IntSet.Lens --- import qualified Data.List.Lens --- import qualified Data.Map.Lens --- import qualified Data.Sequence.Lens --- import qualified Data.Set.Lens --- import qualified Data.Text.Lazy.Lens --- import qualified Data.Text.Lens --- import qualified Data.Text.Strict.Lens --- import qualified Data.Tree.Lens --- import qualified Data.Typeable.Lens --- import qualified Data.Vector.Generic.Lens --- import qualified Data.Vector.Lens --- import qualified GHC.Generics.Lens --- import qualified Generics.Deriving.Lens --- import qualified Language.Haskell.TH.Lens --- import qualified Numeric.Lens --- import qualified System.Exit.Lens --- import qualified System.FilePath.Lens --- import qualified System.IO.Error.Lens - --- import qualified Control.Monad.Cont --- import qualified Control.Monad.Cont.Class --- import qualified Control.Monad.Error.Class --- import qualified Control.Monad.Except --- import qualified Control.Monad.Identity --- import qualified Control.Monad.List --- import qualified Control.Monad.RWS --- import qualified Control.Monad.RWS.Class --- import qualified Control.Monad.RWS.Lazy --- import qualified Control.Monad.RWS.Strict --- import qualified Control.Monad.Reader --- import qualified Control.Monad.Reader.Class --- import qualified Control.Monad.State --- import qualified Control.Monad.State.Class --- import qualified Control.Monad.State.Lazy --- import qualified Control.Monad.State.Strict --- import qualified Control.Monad.Trans --- import qualified Control.Monad.Writer --- import qualified Control.Monad.Writer.Class --- import qualified Control.Monad.Writer.Lazy --- import qualified Control.Monad.Writer.Strict +-- import qualified 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 -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.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 @@ -169,237 +65,59 @@ import qualified Text.PrettyPrint.Annotated.HughesPJ import qualified Text.PrettyPrint.Annotated.HughesPJClass -import qualified Text.PrettyPrint.HughesPJ -import qualified Text.PrettyPrint.HughesPJClass - --- import qualified Data.Generics --- import qualified Data.Generics.Aliases --- import qualified Data.Generics.Basics --- import qualified Data.Generics.Builders --- import qualified Data.Generics.Instances --- import qualified Data.Generics.Schemes --- import qualified Data.Generics.Text --- import qualified Data.Generics.Twins --- import qualified Generics.SYB --- import qualified Generics.SYB.Aliases --- import qualified Generics.SYB.Basics --- import qualified Generics.SYB.Builders --- import qualified Generics.SYB.Instances --- import qualified Generics.SYB.Schemes --- import qualified Generics.SYB.Text --- import qualified Generics.SYB.Twins - -import qualified Data.Text -import qualified Data.Text.Array -import qualified Data.Text.Encoding -import qualified Data.Text.Encoding.Error -import qualified Data.Text.Foreign -import qualified Data.Text.IO --- import qualified Data.Text.Internal --- import qualified Data.Text.Internal.Builder --- import qualified Data.Text.Internal.Builder.Functions --- import qualified Data.Text.Internal.Builder.Int.Digits --- import qualified Data.Text.Internal.Builder.RealFloat.Functions --- import qualified Data.Text.Internal.Encoding.Fusion --- import qualified Data.Text.Internal.Encoding.Fusion.Common --- import qualified Data.Text.Internal.Encoding.Utf16 --- import qualified Data.Text.Internal.Encoding.Utf32 --- import qualified Data.Text.Internal.Encoding.Utf8 --- import qualified Data.Text.Internal.Functions --- import qualified Data.Text.Internal.Fusion --- import qualified Data.Text.Internal.Fusion.CaseMapping --- import qualified Data.Text.Internal.Fusion.Common --- import qualified Data.Text.Internal.Fusion.Size --- import qualified Data.Text.Internal.Fusion.Types --- import qualified Data.Text.Internal.IO --- import qualified Data.Text.Internal.Lazy --- import qualified Data.Text.Internal.Lazy.Encoding.Fusion --- import qualified Data.Text.Internal.Lazy.Fusion --- import qualified Data.Text.Internal.Lazy.Search --- import qualified Data.Text.Internal.Private --- import qualified Data.Text.Internal.Read --- import qualified Data.Text.Internal.Search --- import qualified Data.Text.Internal.Unsafe --- import qualified Data.Text.Internal.Unsafe.Char --- import qualified Data.Text.Internal.Unsafe.Shift -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder --- import qualified Data.Text.Lazy.Builder.Int --- import qualified Data.Text.Lazy.Builder.RealFloat --- import qualified Data.Text.Lazy.Encoding --- import qualified Data.Text.Lazy.IO --- import qualified Data.Text.Lazy.Read --- import qualified Data.Text.Read --- import qualified Data.Text.Unsafe +-- import qualified Text.PrettyPrint.HughesPJ +-- import qualified Text.PrettyPrint.HughesPJClass --- import qualified Control.Applicative.Backwards --- import qualified Control.Applicative.Lift --- import qualified Control.Monad.IO.Class --- import qualified Control.Monad.Signatures --- import qualified Control.Monad.Trans.Class --- import qualified Control.Monad.Trans.Cont --- import qualified Control.Monad.Trans.Except --- import qualified Control.Monad.Trans.Identity --- import qualified Control.Monad.Trans.List --- import qualified Control.Monad.Trans.Maybe --- import qualified Control.Monad.Trans.RWS --- import qualified Control.Monad.Trans.RWS.Lazy --- import qualified Control.Monad.Trans.RWS.Strict --- import qualified Control.Monad.Trans.Reader --- import qualified Control.Monad.Trans.State --- import qualified Control.Monad.Trans.State.Lazy --- import qualified Control.Monad.Trans.State.Strict --- import qualified Control.Monad.Trans.Writer --- import qualified Control.Monad.Trans.Writer.Lazy --- import qualified Control.Monad.Trans.Writer.Strict --- import qualified Data.Functor.Classes --- import qualified Data.Functor.Compose --- import qualified Data.Functor.Constant --- import qualified Data.Functor.Product --- import qualified Data.Functor.Reverse --- import qualified Data.Functor.Sum +-- import qualified 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 Prelude --- import qualified Control.Applicative --- import qualified Control.Arrow --- import qualified Control.Category --- import qualified Control.Concurrent --- import qualified Control.Concurrent.Chan --- import qualified Control.Concurrent.MVar --- import qualified Control.Concurrent.QSem --- import qualified Control.Concurrent.QSemN --- import qualified Control.Exception --- import qualified Control.Exception.Base --- import qualified Control.Monad --- import qualified Control.Monad.Fix --- import qualified Control.Monad.ST --- import qualified Control.Monad.ST.Lazy --- import qualified Control.Monad.ST.Lazy.Unsafe --- import qualified Control.Monad.ST.Strict --- import qualified Control.Monad.ST.Unsafe --- import qualified Control.Monad.Zip -import qualified Data.Bifunctor -import qualified Data.Bits -import qualified Data.Bool -import qualified Data.Char +-- import qualified Data.Bifunctor +-- import qualified Data.Bits +-- import qualified Data.Bool +-- import qualified Data.Char import qualified Data.Coerce -import qualified Data.Complex +-- import qualified Data.Complex import qualified Data.Data -import qualified Data.Dynamic +-- import qualified Data.Dynamic import qualified Data.Either -import qualified Data.Eq -import qualified Data.Fixed +-- 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.Function +-- import qualified Data.Functor +-- import qualified Data.Functor.Identity +-- import qualified Data.IORef +-- import qualified Data.Int +-- import qualified Data.Ix +-- import qualified Data.List import qualified Data.Maybe -import qualified Data.Monoid -import qualified Data.Ord -import qualified Data.Proxy --- import qualified Data.Ratio --- import qualified Data.STRef --- import qualified Data.STRef.Lazy --- import qualified Data.STRef.Strict --- import qualified Data.String --- import qualified Data.Traversable --- import qualified Data.Tuple --- import qualified Data.Type.Bool --- import qualified Data.Type.Coercion --- import qualified Data.Type.Equality --- import qualified Data.Typeable --- import qualified Data.Typeable.Internal --- import qualified Data.Unique --- import qualified Data.Version --- import qualified Data.Void --- import qualified Data.Word -import qualified Debug.Trace --- import qualified Foreign.C --- import qualified Foreign.C.Error --- import qualified Foreign.C.String --- import qualified Foreign.C.Types --- import qualified Foreign.Concurrent --- import qualified Foreign.ForeignPtr --- import qualified Foreign.ForeignPtr.Unsafe --- import qualified Foreign.Marshal --- import qualified Foreign.Marshal.Alloc --- import qualified Foreign.Marshal.Array --- import qualified Foreign.Marshal.Error --- import qualified Foreign.Marshal.Pool --- import qualified Foreign.Marshal.Unsafe --- import qualified Foreign.Marshal.Utils --- import qualified Foreign.Ptr --- import qualified Foreign.StablePtr --- import qualified Foreign.Storable -import qualified Numeric -import qualified Numeric.Natural --- import qualified System.CPUTime --- import qualified System.Console.GetOpt --- import qualified System.Environment --- import qualified System.Exit +-- import qualified 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 System.IO.Error --- import qualified System.IO.Unsafe --- import qualified System.Info --- import qualified System.Mem --- import qualified System.Mem.StableName --- import qualified System.Mem.Weak --- import qualified System.Posix.Types --- import qualified System.Timeout --- import qualified Text.ParserCombinators.ReadP --- import qualified Text.ParserCombinators.ReadPrec --- import qualified Text.Printf --- import qualified Text.Read --- import qualified Text.Read.Lex --- import qualified Text.Show --- import qualified Text.Show.Functions -import qualified Unsafe.Coerce +-- import qualified Unsafe.Coerce --- import qualified Control.Arrow as Arrow --- import qualified Control.Category as Category --- import qualified Control.Concurrent as Concurrent --- import qualified Control.Concurrent.Chan as Chan --- import qualified Control.Concurrent.MVar as MVar --- import qualified Control.Exception as Exception --- import qualified Control.Exception.Base as Exception.Base --- import qualified Control.Monad as Monad --- import qualified Data.Bits as Bits import qualified Data.Bool as Bool --- import qualified Data.Char as Char --- import qualified Data.Complex as Complex --- import qualified Data.Either as Either --- import qualified Data.Eq as Eq import qualified Data.Foldable as Foldable --- import qualified Data.Fixed as Fixed --- import qualified Data.Functor.Identity as Identity --- import qualified Data.IORef as IORef --- import qualified Data.Int as Int --- import qualified Data.Ix as Ix --- import qualified Data.Maybe as Maybe --- import qualified Data.Monoid as Monoid --- import qualified Data.Ord as Ord --- import qualified Data.Proxy as Proxy --- import qualified Data.Traversable as Traversable --- import qualified Data.Void as Void import qualified GHC.OldList as List --- import qualified Text.Printf as Printf import qualified Data.Semigroup as Semigroup import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as ByteStringL --- import qualified Data.IntMap as IntMap import qualified Data.IntMap.Lazy as IntMapL import qualified Data.IntMap.Strict as IntMapS --- import qualified Data.IntSet as IntSet import qualified Data.Map as Map --- import qualified Data.Map.Lazy as MapL --- import qualified Data.Map.Strict as MapS import qualified Data.Sequence as Seq import qualified Data.Set as Set @@ -415,378 +133,15 @@ import qualified Data.Text.Lazy.Encoding as TextL.Encoding import qualified Data.Text.Lazy.IO as TextL.IO --- import qualified Control.Monad.Trans.Class as Trans.Class --- import qualified Control.Monad.Trans.Maybe as Trans.Maybe --- import qualified Control.Monad.Trans.RWS as RWS --- import qualified Control.Monad.Trans.RWS.Lazy as RWSL --- import qualified Control.Monad.Trans.RWS.Strict as RWSS --- import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.State.Lazy as StateL import qualified Control.Monad.Trans.State.Strict as StateS --- import qualified Control.Monad.Trans.Writer as Writer --- import qualified Control.Monad.Trans.Writer.Lazy as WriterL --- import qualified Control.Monad.Trans.Writer.Strict as Writer import qualified Control.Monad.Trans.Either as EitherT import qualified Data.Strict.Maybe as Strict import qualified Safe as Safe -import Data.Functor.Identity ( Identity(..) ) -import Control.Concurrent.Chan ( Chan ) -import Control.Concurrent.MVar ( MVar ) -import Data.Int ( Int ) -import Data.Word ( Word ) -import Prelude ( Integer, Float, Double ) -import Control.Monad.ST ( ST ) -import Data.Bool ( Bool(..) ) -import Data.Char ( Char ) -import Data.Either ( Either(..) ) -import Data.IORef ( IORef ) -import Data.Maybe ( Maybe(..) ) -import Data.Semigroup ( Option(..) ) -import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), Alt(..), ) -import Data.Ord ( Ordering(..), Down(..) ) -import Data.Ratio ( Ratio, Rational ) -import Data.String ( String ) -import Data.Void ( Void ) -import System.IO ( IO ) -import Data.Proxy ( Proxy(..) ) -import Data.Sequence ( Seq ) -import Data.Map ( Map ) -import Data.Set ( Set ) - -import Data.Text ( Text ) - -import Prelude ( Char - , String - , Int - , Integer - , Float - , Double - , Bool (..) - , undefined - , Eq (..) - , Ord (..) - , Enum (..) - , Bounded (..) - , Maybe (..) - , Either (..) - , IO - , (<$>) - , (.) - , ($) - , ($!) - , Num (..) - , Integral (..) - , Fractional (..) - , Floating (..) - , RealFrac (..) - , RealFloat (..) - , fromIntegral - , error - , foldr - , foldl - , foldr1 - , id - , map - , subtract - , putStrLn - , putStr - , Show (..) - , print - , fst - , snd - , (++) - , not - , (&&) - , (||) - , curry - , uncurry - , Ordering (..) - , flip - , const - , seq - , reverse - , otherwise - , traverse - , realToFrac - , or - , and - , head - , any - , (^) - , Foldable - , Traversable - ) - -import Data.Function ( fix - ) - -import Data.Foldable ( foldl' - , foldr' - , fold - , asum - ) - -import Data.List ( partition - , null - , elem - , notElem - , minimum - , maximum - , length - , all - , take - , drop - , find - , sum - , zip - , zip3 - , zipWith - , repeat - , replicate - , iterate - , nub - , filter - , intersperse - , intercalate - , isSuffixOf - , isPrefixOf - , dropWhile - , takeWhile - , unzip - , break - , transpose - , sortBy - , mapAccumL - , mapAccumR - , uncons - ) - -import Data.Tuple ( swap - ) - -import Data.Char ( ord - , chr - ) - -import Data.Maybe ( fromMaybe - , maybe - , listToMaybe - , maybeToList - , catMaybes - ) - -import Data.Word ( Word32 - ) - -import Data.Ord ( comparing - , Down (..) - ) - -import Data.Either ( either - ) - -import Data.Ratio ( Ratio - , (%) - , numerator - , denominator - ) - -import Text.Read ( readMaybe - ) - -import Control.Monad ( Functor (..) - , Monad (..) - , MonadPlus (..) - , mapM - , mapM_ - , forM - , forM_ - , sequence - , sequence_ - , (=<<) - , (>=>) - , (<=<) - , forever - , void - , join - , replicateM - , replicateM_ - , guard - , when - , unless - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , filterM - , (<$!>) - ) - -import Control.Applicative ( Applicative (..) - , Alternative (..) - ) - -import Foreign.Storable ( Storable ) -import GHC.Exts ( Constraint ) - -import Control.Concurrent ( threadDelay - , forkIO - , forkOS - ) - -import Control.Concurrent.MVar ( MVar - , newEmptyMVar - , newMVar - , putMVar - , readMVar - , takeMVar - , swapMVar - ) - -import Control.Exception ( evaluate - , bracket - , assert - ) - -import Debug.Trace ( trace - , traceId - , traceShowId - , traceShow - , traceStack - , traceShowId - , traceIO - , traceM - , traceShowM - ) - -import Foreign.ForeignPtr ( ForeignPtr - ) - -import Data.Monoid ( (<>) - , mconcat - , Monoid (..) - ) - -import Data.Bifunctor ( bimap ) -import Data.Functor ( (<$), ($>) ) -import Data.Function ( (&) ) -import System.IO ( hFlush - , stdout - ) - -import Data.Typeable ( Typeable - ) - -import Control.Arrow ( first - , second - , (***) - , (&&&) - , (>>>) - , (<<<) - ) - -import Data.Functor.Identity ( Identity (..) - ) - -import Data.Proxy ( Proxy (..) - ) - -import Data.Version ( showVersion - ) - -import Data.List.Extra ( nubOrd - , stripSuffix - ) -import Control.Monad.Extra ( whenM - , unlessM - , ifM - , notM - , orM - , andM - , anyM - , allM - ) - -import Data.Tree ( Tree(..) - ) - -import Control.Monad.Trans.MultiRWS ( -- MultiRWST (..) - -- , MultiRWSTNull - -- , MultiRWS - -- , - MonadMultiReader(..) - , MonadMultiWriter(..) - , MonadMultiState(..) - -- , runMultiRWST - -- , runMultiRWSTASW - -- , runMultiRWSTW - -- , runMultiRWSTAW - -- , runMultiRWSTSW - -- , runMultiRWSTNil - -- , runMultiRWSTNil_ - -- , withMultiReader - -- , withMultiReader_ - -- , withMultiReaders - -- , withMultiReaders_ - -- , withMultiWriter - -- , withMultiWriterAW - -- , withMultiWriterWA - -- , withMultiWriterW - -- , withMultiWriters - -- , withMultiWritersAW - -- , withMultiWritersWA - -- , withMultiWritersW - -- , withMultiState - -- , withMultiStateAS - -- , withMultiStateSA - -- , withMultiStateA - -- , withMultiStateS - -- , withMultiState_ - -- , withMultiStates - -- , withMultiStatesAS - -- , withMultiStatesSA - -- , withMultiStatesA - -- , withMultiStatesS - -- , withMultiStates_ - -- , inflateReader - -- , inflateMultiReader - -- , inflateWriter - -- , inflateMultiWriter - -- , inflateState - -- , inflateMultiState - -- , mapMultiRWST - -- , mGetRawR - -- , mGetRawW - -- , mGetRawS - -- , mPutRawR - -- , mPutRawW - -- , mPutRawS - ) - -import Control.Monad.Trans.MultiReader ( runMultiReaderTNil - , runMultiReaderTNil_ - , MultiReaderT (..) - , MultiReader - , MultiReaderTNull - ) - -import Data.Text ( Text ) - -import Control.Monad.IO.Class ( MonadIO (..) - ) - -import Control.Monad.Trans.Class ( lift - ) -import Control.Monad.Trans.Maybe ( MaybeT (..) - ) - import Language.Haskell.Brittany.Internal.Prelude - -import Data.Data ( toConstr - ) +import Language.Haskell.Brittany.Internal.PreludeUtils