From a348ae7fbcc4bfbfb301f6dacd4cc0e096b9c7b2 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 29 Sep 2017 14:59:41 +0200 Subject: [PATCH 001/478] Switch to XDG path for config; Search conf in parents - switch to XDG path should be backwards-compatible: - new config will be written to XDG path - but existing config in ~/.brittany will be respected - looks for "brittany.yaml" not only in cwd, but in parents too. uses the first file found. fixes #45, fixes #55 --- src-brittany/Main.hs | 43 +++++++++++---- .../Haskell/Brittany/Internal/Config.hs | 55 +++++++++++-------- 2 files changed, 65 insertions(+), 33 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 129ee50..71b278a 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -292,15 +292,38 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEi readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do - let defLocalConfigPath = "brittany.yaml" - userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany" - let defUserConfigPath = userBritPath FilePath. "config.yaml" - merged <- case configPaths of + userBritPathSimple <- liftIO $ Directory.getAppUserDataDirectory "brittany" + userBritPathXdg <- liftIO + $ Directory.getXdgDirectory Directory.XdgConfig "brittany" + let userConfigPathSimple = userBritPathSimple FilePath. "config.yaml" + let userConfigPathXdg = userBritPathXdg FilePath. "config.yaml" + let + findLocalConfig :: MaybeT IO (Maybe (CConfig Option)) + findLocalConfig = do + cwd <- liftIO $ Directory.getCurrentDirectory + let dirParts = FilePath.splitDirectories cwd + let searchDirs = + [ FilePath.joinPath x | x <- reverse $ List.inits dirParts ] + -- when cwd is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] + mFilePath <- liftIO $ Directory.findFileWith Directory.doesFileExist + searchDirs + "brittany.yaml" + case mFilePath of + Nothing -> pure Nothing + Just fp -> readConfig fp + configsRead <- case configPaths of [] -> do - liftIO $ Directory.createDirectoryIfMissing False userBritPath - return cmdlineConfig - >>= readMergePersConfig defLocalConfigPath False - >>= readMergePersConfig defUserConfigPath True - -- TODO: ensure that paths exist ? - paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) (return cmdlineConfig) paths + localConfig <- findLocalConfig + userConfigSimple <- readConfig userConfigPathSimple + userConfigXdg <- readConfig userConfigPathXdg + let userConfig = userConfigSimple <|> userConfigXdg + when (Data.Maybe.isNothing userConfig) $ do + liftIO $ Directory.createDirectoryIfMissing False userBritPathXdg + writeDefaultConfig userConfigPathXdg + -- rightmost has highest priority + pure $ [userConfig, localConfig] + paths -> readConfig `mapM` reverse paths + -- reverse to give highest priority to the first + merged <- + pure $ Semigroup.mconcat $ catMaybes $ configsRead ++ [Just cmdlineConfig] return $ cZipWith fromOptionIdentity staticDefaultConfig merged diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 49651d7..baaca1f 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -8,7 +8,8 @@ module Language.Haskell.Brittany.Internal.Config , configParser , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled - , readMergePersConfig + , readConfig + , writeDefaultConfig , showConfigYaml ) where @@ -198,29 +199,37 @@ configParser = do -- , infoIntersperse = True -- } -readMergePersConfig - :: System.IO.FilePath -> Bool -> CConfig Option -> MaybeT IO (CConfig Option) -readMergePersConfig path shouldCreate conf = do + +-- | Reads a config from a file. If the file does not exist, returns +-- Nothing. If the file exists and parsing fails, prints to stderr and +-- aborts the MaybeT. Otherwise succeed via Just. +-- If the second parameter is True and the file does not exist, writes the +-- staticDefaultConfig to the file. +readConfig + :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Option)) +readConfig path = do 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 + if exists + then do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn e + mzero + Right x -> return x + return $ Just fileConf + else return $ Nothing + +writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () +writeDefaultConfig path = + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Option . Just . runIdentity) + staticDefaultConfig showConfigYaml :: Config -> String showConfigYaml = Data.ByteString.Char8.unpack -- 2.30.2 From ccf2eb092f0f9755d64b180807fd69852504f8af Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 1 Oct 2017 17:16:27 +0200 Subject: [PATCH 002/478] Support RecordWildCards, Add one-liner layouting for records fixes #52 --- src-literatetests/tests.blt | 15 +++ .../Brittany/Internal/Layouters/Expr.hs | 125 +++++++++++++----- .../Brittany/Internal/Layouters/Pattern.hs | 20 +++ 3 files changed, 128 insertions(+), 32 deletions(-) diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt index e54841b..f4db082 100644 --- a/src-literatetests/tests.blt +++ b/src-literatetests/tests.blt @@ -1042,6 +1042,21 @@ foo = cccc = () in foo +#test issue 52 a + +{-# LANGUAGE RecordWildCards #-} +v = A {a = 1, ..} where b = 2 + +#test issue 52 b + +{-# LANGUAGE RecordWildCards #-} +v = A {..} where b = 2 + +#test issue 52 c + +{-# LANGUAGE RecordWildCards #-} +v = A {a = 1, b = 2, c = 3} + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a6ba345..2808df2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -672,42 +672,103 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + let line1 appender wrapper = + [ appender $ docLit $ Text.pack "{" + , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , case fd1e of + Just x -> docSeq + [ appSep $ docLit $ Text.pack "=" + , docWrapNodeRest fd1l $ wrapper $ x + ] + Nothing -> docEmpty + ] + let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docWrapNode lfield $ docSeq + [ appSep $ docLit $ Text.pack "=" + , wrapper x + ] + Nothing -> docEmpty + ] + let lineN = + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] docAlt - [ docSetParSpacing + [ docSeq + $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + ++ line1 id docForceSingleline + ++ join (lineR docForceSingleline) + ++ lineN + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docNodeAnnKW lexpr Nothing $ nameDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ docAddBaseY BrIndentRegular $ x - ] - Nothing -> docEmpty - ] - lineR = fdr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "," - , appSep $ docLit $ fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN]) - -- TODO oneliner (?) + ( docNonBottomSpacing + $ docLines + $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] + ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) + ++ [docSeq lineN] + ) ] RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do let t = lrdrNameToText lname docWrapNode lname $ docLit $ t <> Text.pack " {..}" + RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + let line1 appender wrapper = + [ appender $ docLit $ Text.pack "{" + , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , case fd1e of + Just x -> docSeq + [ appSep $ docLit $ Text.pack "=" + , docWrapNodeRest fd1l $ wrapper $ x + ] + Nothing -> docEmpty + ] + let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docWrapNode lfield $ docSeq + [ appSep $ docLit $ Text.pack "=" + , wrapper x + ] + Nothing -> docEmpty + ] + let lineDot = + [ docCommaSep + , docLit $ Text.pack ".." + ] + let lineN = + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + docAlt + [ docSeq + $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + ++ line1 id docForceSingleline + ++ join (lineR docForceSingleline) + ++ lineDot + ++ lineN + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing $ nameDoc) + ( docNonBottomSpacing + $ docLines + $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] + ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) + ++ [docSeq lineDot, docSeq lineN] + ) + ] RecordCon{} -> unknownNodeError "RecordCon with puns" lexpr RecordUpd rExpr [] _ _ _ _ -> do @@ -755,7 +816,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of Nothing -> docEmpty ] lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "," + [ docCommaSep , appSep $ docLit $ fText , case fDoc of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" @@ -785,7 +846,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of Nothing -> docEmpty ] lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "," + [ docCommaSep , appSep $ docLit $ fText , case fDoc of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" @@ -829,7 +890,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of docSeq [ docLit $ Text.pack "[" , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," + , docCommaSep , appSep $ docForceSingleline e2Doc , docLit $ Text.pack "..]" ] @@ -850,7 +911,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of docSeq [ docLit $ Text.pack "[" , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," + , docCommaSep , appSep $ docForceSingleline e2Doc , appSep $ docLit $ Text.pack ".." , docForceSingleline eNDoc diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index b36fcaa..3f66932 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -96,6 +96,26 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of [ appSep $ docLit t , docLit $ Text.pack "{..}" ] + ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return $ (lrdrNameToText lnameF, fExpDoc) + fmap Seq.singleton $ docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case + (fieldName, Just fieldDoc) -> + [ appSep $ docLit $ fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + , docCommaSep + ] + (fieldName, Nothing) -> [docLit fieldName, docCommaSep] + , docLit $ Text.pack "..}" + ] TuplePat args boxity _ -> do case boxity of Boxed -> wrapPatListy args "(" ")" -- 2.30.2 From a0112524aa4752f089758bbfdbe55fbde6566e8d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 2 Oct 2017 20:50:51 +0200 Subject: [PATCH 003/478] Split up littests input into multiple files *.blt instead of just tests.blt yay for unix-style for ordering the inputs "15-regression.blt" --- brittany.cabal | 3 +- src-literatetests/{tests.blt => 10-tests.blt} | 504 ------------------ src-literatetests/15-regressions.blt | 467 ++++++++++++++++ src-literatetests/16-pending.blt | 35 ++ src-literatetests/Main.hs | 7 +- 5 files changed, 509 insertions(+), 507 deletions(-) rename src-literatetests/{tests.blt => 10-tests.blt} (50%) create mode 100644 src-literatetests/15-regressions.blt create mode 100644 src-literatetests/16-pending.blt diff --git a/brittany.cabal b/brittany.cabal index 957fb06..2294238 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -24,7 +24,7 @@ extra-doc-files: { doc/implementation/*.md } extra-source-files: { - src-literatetests/tests.blt + src-literatetests/*.blt } source-repository head { @@ -330,6 +330,7 @@ test-suite littests , czipwith , ghc-boot-th , hspec >=2.4.1 && <2.5 + , filepath , parsec >=3.1.11 && <3.2 } ghc-options: -Wall diff --git a/src-literatetests/tests.blt b/src-literatetests/10-tests.blt similarity index 50% rename from src-literatetests/tests.blt rename to src-literatetests/10-tests.blt index f4db082..696cbb6 100644 --- a/src-literatetests/tests.blt +++ b/src-literatetests/10-tests.blt @@ -589,507 +589,3 @@ func = ] ++ [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 - -#test issue 52 a - -{-# LANGUAGE RecordWildCards #-} -v = A {a = 1, ..} where b = 2 - -#test issue 52 b - -{-# LANGUAGE RecordWildCards #-} -v = A {..} where b = 2 - -#test issue 52 c - -{-# LANGUAGE RecordWildCards #-} -v = A {a = 1, b = 2, c = 3} - - -############################################################################### -############################################################################### -############################################################################### -#group pending -############################################################################### -############################################################################### -############################################################################### - - - -## this testcase is not about idempotency, but about _how_ the output differs -## from the input; i cannot really express this yet with the current -## test-suite. -## #test ayaz -## -## myManageHook = -## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] -## <+> composeAll -## [ className =? "Pidgin" --> doFloat -## , className =? "XCalc" --> doFloat -## -- plan9port's acme -## , className =? "acme" --> doFloat -## -- Acme with Vi bindings editor -## , title =? "ED" --> doFloat -## , title =? "wlc-x11" --> doFloat -## , className =? "Skype" --> doFloat -## , className =? "ffplay" --> doFloat -## , className =? "mpv" --> doFloat -## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc. -## -- Firefox works well tiled, but it has dialog windows we want to float. -## , appName =? "Browser" --> doFloat -## ] -## where -## role = stringProperty "WM_WINDOW_ROLE" - diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt new file mode 100644 index 0000000..0a63b7a --- /dev/null +++ b/src-literatetests/15-regressions.blt @@ -0,0 +1,467 @@ +############################################################################### +############################################################################### +############################################################################### +#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 + +#test issue 52 a + +{-# LANGUAGE RecordWildCards #-} +v = A {a = 1, ..} where b = 2 + +#test issue 52 b + +{-# LANGUAGE RecordWildCards #-} +v = A {..} where b = 2 + +#test issue 52 c + +{-# LANGUAGE RecordWildCards #-} +v = A {a = 1, b = 2, c = 3} + diff --git a/src-literatetests/16-pending.blt b/src-literatetests/16-pending.blt new file mode 100644 index 0000000..c8147d8 --- /dev/null +++ b/src-literatetests/16-pending.blt @@ -0,0 +1,35 @@ +############################################################################### +############################################################################### +############################################################################### +#group pending +############################################################################### +############################################################################### +############################################################################### + + + +## this testcase is not about idempotency, but about _how_ the output differs +## from the input; i cannot really express this yet with the current +## test-suite. +## #test ayaz +## +## myManageHook = +## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] +## <+> composeAll +## [ className =? "Pidgin" --> doFloat +## , className =? "XCalc" --> doFloat +## -- plan9port's acme +## , className =? "acme" --> doFloat +## -- Acme with Vi bindings editor +## , title =? "ED" --> doFloat +## , title =? "wlc-x11" --> doFloat +## , className =? "Skype" --> doFloat +## , className =? "ffplay" --> doFloat +## , className =? "mpv" --> doFloat +## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc. +## -- Firefox works well tiled, but it has dialog windows we want to float. +## , appName =? "Browser" --> doFloat +## ] +## where +## role = stringProperty "WM_WINDOW_ROLE" + diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index fe966e6..34b4e4e 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -24,6 +24,7 @@ import Language.Haskell.Brittany.Internal.Config import Data.Coerce ( coerce ) import qualified Data.Text.IO as Text.IO +import System.FilePath ( () ) @@ -38,8 +39,10 @@ data InputLine main :: IO () main = do - input <- Text.IO.readFile "src-literatetests/tests.blt" - let groups = createChunks input + files <- System.Directory.listDirectory "src-literatetests/" + let blts = List.sort $ filter (".blt" `isSuffixOf`) files + inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) + let groups = createChunks =<< inputs hspec $ groups `forM_` \(groupname, tests) -> do describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do (if pend then before_ pending else id) -- 2.30.2 From f21c6b6eacad4542a2c02606d43ba70814d7a919 Mon Sep 17 00:00:00 2001 From: d-dorazio Date: Tue, 3 Oct 2017 23:32:36 +0200 Subject: [PATCH 004/478] rework the cli interface --- brittany.cabal | 8 +++---- src-brittany/Main.hs | 54 +++++++++++++++++++++++++------------------- stack.yaml | 2 +- 3 files changed, 36 insertions(+), 28 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 2294238..ca639b8 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -102,7 +102,7 @@ library { , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4 - , butcher >=1.1.0.0 && <1.2 + , butcher >=1.2 && <1.3 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 , extra >=1.4.10 && <1.7 @@ -147,7 +147,7 @@ executable brittany other-modules: { Paths_brittany } - -- other-extensions: + -- other-extensions: build-depends: { brittany , base @@ -335,7 +335,7 @@ test-suite littests } ghc-options: -Wall main-is: Main.hs - other-modules: + other-modules: hs-source-dirs: src-literatetests default-extensions: { CPP @@ -379,7 +379,7 @@ test-suite libinterfacetests } ghc-options: -Wall main-is: Main.hs - other-modules: + other-modules: hs-source-dirs: src-libinterfacetests default-extensions: { FlexibleContexts diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 8edc6b6..4f6992e 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -12,8 +12,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Data.Map as Map +import Text.Read (Read(..)) +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec import qualified Data.Text.Lazy.Builder as Text.Builder +import Control.Monad (zipWithM) import Data.CZipWith import qualified Debug.Trace as Trace @@ -39,6 +43,17 @@ import qualified GHC.LanguageExtensions.Type as GHC import Paths_brittany +data WriteMode = Display | Inplace + +instance Read WriteMode where + readPrec = val "display" Display <|> val "inplace" Inplace + where + val iden v = ReadPrec.lift $ ReadP.string iden >> return v + +instance Show WriteMode where + show Display = "display" + show Inplace = "inplace" + main :: IO () main = mainFromCmdParserWithHelpDesc mainCmdParser @@ -103,8 +118,6 @@ mainCmdParser helpDesc = do printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty - inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "paths to input haskell source files") - outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file paths") configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? cmdlineConfig <- configParser suppressOutput <- addSimpleBoolFlag @@ -112,10 +125,17 @@ mainCmdParser helpDesc = do ["suppress-output"] (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source") _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]") - inplace <- addSimpleBoolFlag "" ["inplace"] (flagHelp $ parDoc "overwrite the input files") + writeMode <- addFlagReadParam + "" + ["write-mode"] + "" + Flag + { _flag_help = Just (PP.text "output mode: [display|inplace]") + , _flag_default = Just Display + } reorderStop - inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file") - desc <- peekCmdDesc + inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") + desc <- peekCmdDesc addCmdImpl $ void $ do when printLicense $ do print licenseDoc @@ -130,21 +150,10 @@ mainCmdParser helpDesc = do liftIO $ print $ ppHelpShallow desc System.Exit.exitSuccess - let inputPaths' = case maybeToList inputParam ++ inputPaths of - [] -> [Nothing] - ps -> map Just ps - - outputPaths' <- case outputPaths of - [] | not inplace -> return [Nothing] - [] -> return inputPaths' - ps | not inplace -> return . map Just $ ps - _ -> do - putStrErrLn "cannot specify output files and inplace at the same time" - System.Exit.exitWith (System.Exit.ExitFailure 51) - - when (length inputPaths' /= length outputPaths') $ do - putStrErrLn "the number of inputs must match ther number of outputs" - System.Exit.exitWith (System.Exit.ExitFailure 52) + let inputPaths = if null inputParams then [Nothing] else map Just inputParams + let outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) @@ -152,9 +161,8 @@ mainCmdParser helpDesc = do when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do trace (showConfigYaml config) $ return () - let ios = zipWith (coreIO putStrErrLn config suppressOutput) inputPaths' outputPaths' - res <- fmap sequence_ $ sequence ios - case res of + results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths + case sequence_ results of Left _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) Right _ -> pure () diff --git a/stack.yaml b/stack.yaml index 4bbcc0c..539cd6d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,7 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.0.0 - - butcher-1.1.0.2 + - butcher-1.2.0.0 - data-tree-print-0.1.0.0 - deque-0.2 -- 2.30.2 From 752048882e6049f02413bbd2882ea2066e43a50b Mon Sep 17 00:00:00 2001 From: d-dorazio Date: Wed, 4 Oct 2017 20:56:37 +0200 Subject: [PATCH 005/478] move inputParams into the reordered block --- src-brittany/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 4f6992e..76ed94e 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -133,8 +133,8 @@ mainCmdParser helpDesc = do { _flag_help = Just (PP.text "output mode: [display|inplace]") , _flag_default = Just Display } - reorderStop inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") + reorderStop desc <- peekCmdDesc addCmdImpl $ void $ do when printLicense $ do -- 2.30.2 From 7d7ec3e8b4793a163f38f257cbb9b87b7760928e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 4 Oct 2017 23:43:30 +0200 Subject: [PATCH 006/478] Update commandline help output --- src-brittany/Main.hs | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 76ed94e..4928acf 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -62,13 +62,24 @@ helpDoc :: PP.Doc helpDoc = PP.vcat $ List.intersperse (PP.text "") [ parDocW - [ "Transforms one haskell module by reformatting" - , "(parts of) the source code (while preserving the" - , "parts not transformed)." + [ "Reformats one or more haskell modules." + , "Currently affects only type signatures and function bindings;" + , "everything else is left unmodified." , "Based on ghc-exactprint, thus (theoretically) supporting all" , "that ghc does." - , "Currently, only type-signatures and function-bindings are transformed." ] + , parDoc $ "Example invocations:" + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany" + , PP.hang (PP.text " ") 2 $ PP.text "read from stdin, output to stdout" + ] + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" + , PP.nest 2 $ PP.vcat + [ PP.text "run on all modules in current directory (no backup!)" + , PP.text "4 spaces indentation" + ] + ] , parDocW [ "This program is written carefully and contains safeguards to ensure" , "the transformation does not change semantics (or the syntax tree at all)" @@ -128,9 +139,12 @@ mainCmdParser helpDesc = do writeMode <- addFlagReadParam "" ["write-mode"] - "" + "(display|inplace)" Flag - { _flag_help = Just (PP.text "output mode: [display|inplace]") + { _flag_help = Just $ PP.vcat + [ PP.text "display: output for any input(s) goes to stdout" + , PP.text "inplace: override respective input file (without backup!)" + ] , _flag_default = Just Display } inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") -- 2.30.2 From f86665a251463daa03b8f6f39118b11beaca5d54 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 14 Oct 2017 23:21:13 +0200 Subject: [PATCH 007/478] Fix promoted HsTyVars on ghc-8.2.1 This fix does not work on ghc-8.0, because I do not understand the 8.0 API in this instance. Could be resolved by looking at annotations, but that really should not be necessary. --- src-literatetests/15-regressions.blt | 12 ++++++++++++ .../Brittany/Internal/LayouterBasics.hs | 4 ++++ .../Brittany/Internal/Layouters/Type.hs | 18 +++++++++++++----- 3 files changed, 29 insertions(+), 5 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0a63b7a..2a7185b 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -465,3 +465,15 @@ v = A {..} where b = 2 {-# LANGUAGE RecordWildCards #-} v = A {a = 1, b = 2, c = 3} +#test issue 63 a +#pending fix does not work on 8.0.2 +test :: Proxy 'Int + +#test issue 63 b +#pending fix does not work on 8.0.2 +test :: Proxy '[ 'True] + +#test issue 63 c +#pending fix does not work on 8.0.2 +test :: Proxy '[Bool] + diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index cffcad7..14a0510 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -42,6 +42,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , appSep , docCommaSep , docParenLSep + , docTick , spacifyDocs , briDocMToPPM , allocateNode @@ -447,6 +448,9 @@ docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered docParenLSep = appSep $ docLit $ Text.pack "(" +docTick :: ToBriDocM BriDocNumbered +docTick = docLit $ Text.pack "'" + docNodeAnnKW :: Data.Data.Data ast => Located ast diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 36d1633..9fa7262 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -29,12 +29,20 @@ 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 + HsTyVar promoted name -> do + t <- lrdrNameToTextAnn name + case promoted of + Promoted -> docSeq + [ docSeparator + , docTick + , docWrapNode name $ docLit t + ] + NotPromoted -> docWrapNode name $ docLit t #else /* ghc-8.0 */ HsTyVar name -> do -#endif t <- lrdrNameToTextAnn name docWrapNode name $ docLit t +#endif HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- bndrs `forM` \case @@ -294,7 +302,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of docAlt [ docSeq [ docForceSingleline typeDoc1 - , docLit $ Text.pack " " + , docSeparator , docForceSingleline typeDoc2 ] , docPar @@ -324,7 +332,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of docAlt [ docSeq $ docForceSingleline docHead : (docRest >>= \d -> - [ docLit $ Text.pack " ", docForceSingleline d ]) + [ docSeparator, docForceSingleline d ]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] HsAppsTy (typHead:typRest) -> do @@ -333,7 +341,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of docAlt [ docSeq $ docForceSingleline docHead : (docRest >>= \d -> - [ docLit $ Text.pack " ", docForceSingleline d ]) + [ docSeparator, docForceSingleline d ]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] where -- 2.30.2 From b1c6be7acd3a65bd55667388288ea15c1ea31cba Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 15 Oct 2017 00:23:14 +0200 Subject: [PATCH 008/478] Fix parentheses around kind signatures, fixes #64 --- src-literatetests/15-regressions.blt | 9 +++ .../Brittany/Internal/LayouterBasics.hs | 14 +++++ .../Brittany/Internal/Layouters/Type.hs | 56 +++++++++++++++---- 3 files changed, 67 insertions(+), 12 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 2a7185b..bea97cc 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -477,3 +477,12 @@ test :: Proxy '[ 'True] #pending fix does not work on 8.0.2 test :: Proxy '[Bool] +#test issue 64 +{-# LANGUAGE RankNTypes, KindSignatures #-} +func + :: forall m str + . (Str str, Monad m) + => Int + -> Proxy (str :: [*]) + -> m (Tagged str String) + diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 14a0510..a0a3c7b 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -48,6 +48,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , allocateNode , docSharedWrapper , hasAnyCommentsBelow + , hasAnnKeyword ) where @@ -239,6 +240,19 @@ hasAnyCommentsBelow ast@(L l _) = do $ Map.elems $ anns +hasAnnKeyword + :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) + => Located a + -> AnnKeywordId + -> m Bool +hasAnnKeyword ast annKeyword = do + anns <- mAsk + let hasK (ExactPrint.Types.G x, _) = x == annKeyword + hasK _ = False + pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> False + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + -- new BriDoc stuff allocateNode diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 9fa7262..a5148f5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -14,7 +14,11 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import RdrName ( RdrName(..) ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId (..) + ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import HsSyn import Name @@ -521,19 +525,47 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsKindSig typ1 kind1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 kindDoc1 <- docSharedWrapper layoutType kind1 + hasParens <- hasAnnKeyword ltype AnnOpenP docAlt - [ docSeq - [ docForceSingleline typeDoc1 - , docLit $ Text.pack " :: " - , docForceSingleline kindDoc1 - ] - , docPar + [ if hasParens + then docSeq + [ docLit $ Text.pack "(" + , docForceSingleline typeDoc1 + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , docForceSingleline kindDoc1 + , docLit $ Text.pack ")" + ] + else docSeq + [ docForceSingleline typeDoc1 + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , docForceSingleline kindDoc1 + ] + , if hasParens + then docLines + [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 3) $ typeDoc1 + ] + , docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ] + , (docLit $ Text.pack ")") + ] + else docPar typeDoc1 - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype - $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ]) + ( docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ] + ) ] HsBangTy{} -> -- TODO briDocByExactInlineOnly "HsBangTy{}" ltype -- 2.30.2 From 585c345c356f8e8dd2db564503a8c1f8d8c31fbb Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 15 Oct 2017 00:32:10 +0200 Subject: [PATCH 009/478] Fix silently broken travis setup (rahhh) --- .travis.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8b62149..da510f3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -180,7 +180,7 @@ before_install: - | function better_wait() { date - time "$*" & # send the long living command to background! + time "$@" & # send the long living command to background! set +x MINUTES=0 @@ -231,7 +231,7 @@ install: echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M500M"; + cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M500M -RTS"; fi # snapshot package-db on cache miss @@ -259,12 +259,12 @@ script: set -ex case "$BUILD" in stack) - better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M" + better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS" ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging - better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M" # this builds all libraries and executables (including tests/benchmarks) + better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" # this builds all libraries and executables (including tests/benchmarks) cabal test ;; cabaldist) @@ -275,12 +275,12 @@ script: # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && - (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M") + (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M -RTS") ;; canew) better_wait cabal new-build -j$JOBS --disable-tests --disable-benchmarks better_wait cabal new-build -j$JOBS --enable-tests --enable-benchmarks - cabal new-test --ghc-options="-j1 +RTS -M500M" + cabal new-test --ghc-options="-j1 +RTS -M500M -RTS" ;; esac set +ex -- 2.30.2 From ddd7c6b439588547d488574b5c019df029dc9d77 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 24 Oct 2017 00:00:34 +0200 Subject: [PATCH 010/478] Fix some rare issue and add some comments (it is so rare i cannot reproduce anymore right now, because the code that caused it has changed since..) --- .../Brittany/Internal/Layouters/Expr.hs | 23 +++++++++++++++---- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 2808df2..90fd435 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -154,19 +154,32 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 docAlt - [ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] - , docSetParSpacing + [ -- func arg + docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + , -- func argline1 + -- arglines + -- e.g. + -- func if x + -- then 1 + -- else 2 + docSetParSpacing $ docAddBaseY BrIndentRegular $ docSeq [ appSep $ docForceSingleline expDoc1 , docForceParSpacing expDoc2 ] - , docSetParSpacing + , -- func + -- arg + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docForceSingleline expDoc1) - expDoc2 - , docAddBaseY BrIndentRegular + (docNonBottomSpacing expDoc2) + , -- fu + -- nc + -- ar + -- gument + docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 -- 2.30.2 From 338beb8eea96809c0030541f96ff8fd1c8c0f68c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 24 Oct 2017 00:15:53 +0200 Subject: [PATCH 011/478] Move testcases for extensions in separate testfile --- src-literatetests/10-tests.blt | 44 ------------------------- src-literatetests/14-extensions.blt | 50 +++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 44 deletions(-) create mode 100644 src-literatetests/14-extensions.blt diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 696cbb6..03b1c6b 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -260,21 +260,6 @@ func -- b ) -- j -- k -############################################################################### - -#test ImplicitParams 1 -{-# LANGUAGE ImplicitParams #-} -func :: (?asd::Int) -> () - -#test ImplicitParams 2 -{-# LANGUAGE ImplicitParams #-} -func - :: ( ?asd - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> () - ############################################################################### ############################################################################### @@ -454,12 +439,6 @@ func = 1.1e5 func = 'x' func = 981409823458910394810928414192837123987123987123 -#test lambdacase -{-# LANGUAGE LambdaCase #-} -func = \case - FooBar -> x - Baz -> y - #test lambda func = \x -> abc @@ -550,29 +529,6 @@ func = ] -############################################################################### -############################################################################### -############################################################################### -#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 - - ############################################################################### ############################################################################### ############################################################################### diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt new file mode 100644 index 0000000..d038b64 --- /dev/null +++ b/src-literatetests/14-extensions.blt @@ -0,0 +1,50 @@ +############################################################################### +############################################################################### +############################################################################### +#group extensions +############################################################################### +############################################################################### +############################################################################### + +############################################################################### +## MultiWayIf +#test multiwayif 1 +{-# LANGUAGE MultiWayIf #-} +func = if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 + +#test multiwayif 2 +{-# LANGUAGE MultiWayIf #-} +func = do + foo + bar $ if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 + + +############################################################################### +## LambdaCase +#test lambdacase 1 +{-# LANGUAGE LambdaCase #-} +func = \case + FooBar -> x + Baz -> y + + + +############################################################################### +## ImplicitParams +#test ImplicitParams 1 +{-# LANGUAGE ImplicitParams #-} +func :: (?asd::Int) -> () + +#test ImplicitParams 2 +{-# LANGUAGE ImplicitParams #-} +func + :: ( ?asd + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> () + -- 2.30.2 From 26f8cdfb659876f6233dac70dd76c64578c9048d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 24 Oct 2017 00:16:49 +0200 Subject: [PATCH 012/478] Support RecursiveDo/`rec` keyword --- src-literatetests/14-extensions.blt | 18 ++++++++++++++++++ .../Brittany/Internal/Layouters/Stmt.hs | 6 ++++++ 2 files changed, 24 insertions(+) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index d038b64..896d105 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -48,3 +48,21 @@ func ) -> () + +############################################################################### +## RecursiveDo +#test recursivedo 1 +{-# LANGUAGE RecursiveDo #-} +foo = do + rec a <- f b + b <- g a + return (a, b) + +#test recursivedo 2 +{-# LANGUAGE RecursiveDo #-} +foo = do + rec -- comment + a <- f b + b <- g a + return (a, b) + diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 692b467..a8d95aa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -70,6 +70,12 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) ] + RecStmt stmts _ _ _ _ _ _ _ _ _ -> do + docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts + ] BodyStmt expr _ _ _ -> do expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc -- 2.30.2 From f46fcc135d7985c8c95025e21f0aa5a1d09fe16f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 8 Nov 2017 21:54:32 +0100 Subject: [PATCH 013/478] Update doc/HCAR entry --- doc/hcar/Brittany.tex | 55 ++++++++++++++++++------------------------- 1 file changed, 23 insertions(+), 32 deletions(-) diff --git a/doc/hcar/Brittany.tex b/doc/hcar/Brittany.tex index 5c6760d..f181b2f 100644 --- a/doc/hcar/Brittany.tex +++ b/doc/hcar/Brittany.tex @@ -1,6 +1,6 @@ -% Brittany-LE.tex -\begin{hcarentry}[new]{Brittany} -\report{Lennart Spitzner}%11/16 +% Brittany-LB.tex +\begin{hcarentry}[updated]{Brittany} +\report{Lennart Spitzner}%11/17 \status{work in progress} \makeheader @@ -11,44 +11,35 @@ haskell-src-exts such as hindent or haskell-formatter. The goals of the project are to: \begin{compactitem} -\item - support the full ghc-haskell syntax including syntactic extensions; -\item - retain newlines and comments unmodified (to the degree possible when code - around them gets reformatted); -\item - be clever about using horizontal space while not overflowing it if it cannot - be avoided; -\item - have linear complexity in the size of the input text / the number of +\item support the full ghc-haskell syntax including syntactic extensions; +\item retain newlines and comments unmodified (to the degree possible when + code around them gets reformatted); +\item be clever about using horizontal space while not overflowing it if it + cannot be avoided; +\item have linear complexity in the size of the input text / the number of syntactic nodes in the input. -\item - support horizontal alignments (e.g. different equations/pattern matches in - the some function's definition). +\item support horizontal alignments (e.g. different equations/pattern matches + in the some function's definition). \end{compactitem} -In contrast to other formatters brittany internally works in two steps: Firstly -transforming the syntax tree into a document tree representation, similar to -the document representation in general-purpose pretty-printers such as the -\emph{pretty} package, but much more specialized for the specific purpose of -handling a Haskell source code document. Secondly this document representation -is transformed into the output text document. This approach allows to handle -many different syntactic constructs in a uniform way, making it possible -to attain the above goals with a manageable amount of work. +In contrast to other formatters brittany internally works in two steps: +Firstly transforming the syntax tree into a document tree representation, +similar to the document representation in general-purpose pretty-printers such +as the \emph{pretty} package, but much more specialized for the specific +purpose of handling a Haskell source code document. Secondly this document +representation is transformed into the output text document. This approach +allows to handle many different syntactic constructs in a uniform way, making +it possible to attain the above goals with a manageable amount of work. Brittany is work in progress; currently only type signatures and function bindings are transformed, and not all syntactic constructs are supported. -Nonetheless Brittany is safe to try/use as there are checks in place to -ensure that the output is syntactically valid. +Nonetheless Brittany is safe to try/use as there are checks in place to ensure +that the output is syntactically valid. -Brittany requires ghc-8, and is not released on hackage yet; for a description -of how to build it see the repository README. +Brittany requires ghc-8.*, and is available on Hackage and on Stackage. \FurtherReading -{\small \begin{compactitem} - \item - \url{https://github.com/lspitzner/brittany} + \item \url{https://github.com/lspitzner/brittany} \end{compactitem} -} \end{hcarentry} -- 2.30.2 From 37436e675aff945d756d49cecbd3487f428da507 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 25 Nov 2017 00:58:33 +0100 Subject: [PATCH 014/478] Update README.md: Mention stackage nightly, contribution, dev branch --- README.md | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index d32a189..5d232a2 100644 --- a/README.md +++ b/README.md @@ -46,6 +46,7 @@ require fixing: # Other usage notes - Supports GHC versions `8.0.*` and `8.2.*`. +- as of November'17, `brittany` is available on stackage nightly. - config (file) documentation is lacking. - some config values can not be configured via commandline yet. - uses/creates user config file in `~/.brittany/config.yaml`; @@ -109,9 +110,21 @@ require fixing: - -XBangPatterns ~~~~ -# Implementation/High-level Documentation +# Feature Requests, Contribution, Documentation -[See the documentation index](doc/implementation/index.md) +This currently is a one-person project in the sense that 90% of the code is +written by one person. And (unfortunately) it is not my job to keep improving +this project. Please forgive that as a consequence my time to invest on new +features is rather limited. + +Nonetheless I consider it "in active development" :) + +One way of speeding things up is to make your own contributions. There is +a good amount of high-level documentation at + +[the documentation index](doc/implementation/index.md) + +Note that most development happens on the `dev` branch of this repository! # License -- 2.30.2 From c7095132094d1adcc8622cd4ded738131432f9dc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 25 Nov 2017 19:23:56 +0100 Subject: [PATCH 015/478] Remove dependency on either package Following the deprecation and removal of the EitherT transformer --- brittany.cabal | 4 -- src-brittany/Main.hs | 8 ++-- src/Language/Haskell/Brittany/Internal.hs | 8 ++-- .../Brittany/Internal/ExactPrintUtils.hs | 37 +++++++++---------- srcinc/prelude.inc | 2 +- 5 files changed, 26 insertions(+), 33 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index ca639b8..bf2ba63 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -112,7 +112,6 @@ library { , unsafe >=0.0 && <0.1 , safe >=0.3.9 && <0.4 , deepseq >=1.4.2.0 && <1.5 - , either >=4.4.1.1 && <4.5 , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1 @@ -175,7 +174,6 @@ executable brittany , unsafe , safe , deepseq - , either , semigroups , cmdargs , czipwith @@ -252,7 +250,6 @@ test-suite unittests , unsafe , safe , deepseq - , either , semigroups , cmdargs , czipwith @@ -324,7 +321,6 @@ test-suite littests , unsafe , safe , deepseq - , either , semigroups , cmdargs , czipwith diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 4928acf..046c830 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -193,8 +193,8 @@ coreIO -> 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 () +coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runExceptT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let ghcOptions = config & _conf_forward & _options_ghc & runIdentity -- there is a good of code duplication between the following code and the -- `pureModuleTransform` function. Unfortunately, there are also a good @@ -234,7 +234,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEi Left left -> do putErrorLn "parse error:" putErrorLn $ show left - EitherT.left 60 + ExceptT.throwE 60 Right (anns, parsedSource, hasCPP) -> do when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource @@ -300,7 +300,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEi Nothing -> liftIO $ TextL.IO.putStr $ outLText Just p -> liftIO $ TextL.IO.writeFile p $ outLText - when hasErrors $ EitherT.left 70 + when hasErrors $ ExceptT.throwE 70 where addTraceSep conf = if or diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 4c4bbf0..64c139a 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -20,7 +20,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data -import Control.Monad.Trans.Either +import Control.Monad.Trans.Except import Data.HList.HList import Data.CZipWith @@ -62,7 +62,7 @@ import qualified GHC.LanguageExtensions.Type as GHC -- Note that this function ignores/resets all config values regarding -- debugging, i.e. it will never use `trace`/write to stderr. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) -parsePrintModule configRaw inputText = runEitherT $ do +parsePrintModule configRaw inputText = runExceptT $ do let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let config_pp = config & _conf_preprocessor @@ -87,7 +87,7 @@ parsePrintModule configRaw inputText = runEitherT $ do cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> left $ [ErrorInput err] + Left err -> throwE $ [ErrorInput err] Right x -> pure $ x (errsWarns, outputTextL) <- do let omitCheck = @@ -117,7 +117,7 @@ parsePrintModule configRaw inputText = runEitherT $ do case config & _conf_errorHandling & _econf_Werror & confUnpack of False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) True -> not $ null errsWarns - if hasErrors then left $ errsWarns else pure $ TextL.toStrict outputTextL + if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index faa9526..74ed50d 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -58,26 +58,24 @@ parseModuleWithCpp -> (GHC.DynFlags -> IO (Either String a)) -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleWithCpp cpp opts args fp dynCheck = - ExactPrint.ghcWrapper $ EitherT.runEitherT $ do + ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ GHC.getSessionDynFlags - (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine - dflags0 - (GHC.noLoc <$> args) + (dflags1, leftover, warnings) <- lift + $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) void $ lift $ GHC.setSessionDynFlags dflags1 - dflags2 <- lift $ ExactPrint.initDynFlags fp + dflags2 <- lift $ ExactPrint.initDynFlags fp when (not $ null leftover) - $ EitherT.left + $ ExceptT.throwE $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) when (not $ null warnings) - $ EitherT.left + $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s) - x <- EitherT.EitherT $ liftIO $ dynCheck dflags2 + x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp - EitherT.hoistEither - $ either (\(span, err) -> Left $ show span ++ ": " ++ err) - (\(a, m) -> Right (a, m, x)) + either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) + (\(a, m) -> pure (a, m, x)) $ ExactPrint.postParseTransform res opts parseModuleFromString @@ -87,22 +85,21 @@ parseModuleFromString -> String -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleFromString args fp dynCheck str = - ExactPrint.ghcWrapper $ EitherT.runEitherT $ do + ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str - (dflags1, leftover, warnings) <- - lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) + (dflags1, leftover, warnings) <- lift + $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) when (not $ null leftover) - $ EitherT.left + $ ExceptT.throwE $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) when (not $ null warnings) - $ EitherT.left + $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s) - x <- EitherT.EitherT $ liftIO $ dynCheck dflags1 - EitherT.hoistEither - $ either (\(span, err) -> Left $ show span ++ ": " ++ err) - (\(a, m) -> Right (a, m, x)) + x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 + either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) + (\(a, m) -> pure (a, m, x)) $ ExactPrint.parseWith dflags1 fp GHC.parseModule str ----------- diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc index 805b941..81ca53a 100644 --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -136,7 +136,7 @@ import qualified Data.Text.Lazy.IO as TextL.IO import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.State.Lazy as StateL import qualified Control.Monad.Trans.State.Strict as StateS -import qualified Control.Monad.Trans.Either as EitherT +import qualified Control.Monad.Trans.Except as ExceptT import qualified Data.Strict.Maybe as Strict -- 2.30.2 From fdd2f5f6dc2ac4e5e307e50f16d373db0d5210b5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 26 Nov 2017 21:28:06 +0100 Subject: [PATCH 016/478] Try fix shitty travis CI script again --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index da510f3..5922f50 100644 --- a/.travis.yml +++ b/.travis.yml @@ -196,6 +196,7 @@ before_install: sleep 60 done + wait $! set -x } -- 2.30.2 From 4568bd35533854a3950376bf3a13b96a941f25ad Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Sep 2017 23:26:23 +0200 Subject: [PATCH 017/478] Prepare implementation for `IndentPolicyLeft` --- .../Haskell/Brittany/Internal/Config/Types.hs | 2 +- .../Brittany/Internal/Layouters/Expr.hs | 1850 +++++++++-------- .../Brittany/Internal/Layouters/Stmt.hs | 101 +- 3 files changed, 978 insertions(+), 975 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 4fd4765..d726d8a 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -191,7 +191,7 @@ data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more | IndentPolicyFree -- can create new indentations whereever | IndentPolicyMultiple -- can create indentations only -- at any n * amount. - deriving (Show, Generic, Data) + deriving (Eq, Show, Generic, Data) data AltChooser = AltChooserSimpleQuick -- always choose last alternative. -- leads to tons of sparsely filled diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 90fd435..fe82e3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -13,6 +13,7 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) ) @@ -30,973 +31,974 @@ import Language.Haskell.Brittany.Internal.Layouters.Type layoutExpr :: ToBriDoc HsExpr -layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of - HsVar vname -> do - docLit =<< lrdrNameToTextAnn vname - HsUnboundVar var -> case var of - OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname - TrueExprHole oname -> docLit $ Text.pack $ occNameString oname - HsRecFld{} -> do - -- TODO - briDocByExactInlineOnly "HsRecFld" lexpr - HsOverLabel{} -> do - -- TODO - briDocByExactInlineOnly "HsOverLabel{}" lexpr - HsIPVar{} -> do - -- TODO - briDocByExactInlineOnly "HsOverLabel{}" lexpr - HsOverLit (OverLit olit _ _ _) -> do - allocateNode $ overLitValBriDoc olit - HsLit lit -> do - allocateNode $ litBriDoc lit - HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p - bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let funcPatternPartLine = - docCols ColCasePattern - $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq +layoutExpr lexpr@(L _ expr) = do + docWrapNode lexpr $ case expr of + HsVar vname -> do + docLit =<< lrdrNameToTextAnn vname + HsUnboundVar var -> case var of + OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname + TrueExprHole oname -> docLit $ Text.pack $ occNameString oname + HsRecFld{} -> do + -- TODO + briDocByExactInlineOnly "HsRecFld" lexpr + HsOverLabel{} -> do + -- TODO + briDocByExactInlineOnly "HsOverLabel{}" lexpr + HsIPVar{} -> do + -- TODO + briDocByExactInlineOnly "HsOverLabel{}" lexpr + HsOverLit (OverLit olit _ _ _) -> do + allocateNode $ overLitValBriDoc olit + HsLit lit -> do + allocateNode $ litBriDoc lit + HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do + patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let funcPatternPartLine = + docCols ColCasePattern + $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing - $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> - unknownNodeError "HsLam too complex" lexpr -#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 - (docLit $ Text.pack "\\case") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - HsApp exp1@(L _ HsApp{}) exp2 -> do - let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) - gather list = \case - (L _ (HsApp l r)) -> gather (r:list) l - x -> (x, list) - let (headE, paramEs) = gather [exp2] exp1 - headDoc <- docSharedWrapper layoutExpr headE - paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - docAlt - [ -- foo x y - docCols ColApp - $ appSep (docForceSingleline headDoc) - : spacifyDocs (docForceSingleline <$> paramDocs) - , -- foo x - -- y - docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular - $ docLines - $ (docForceSingleline <$> paramDocs) + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing + $ docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) ] - , -- foo - -- x - -- y - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline headDoc) - ( docNonBottomSpacing - $ docLines paramDocs - ) - , -- ( multi - -- line - -- function - -- ) - -- x - -- y - docAddBaseY BrIndentRegular - $ docPar - headDoc - ( docNonBottomSpacing - $ docLines paramDocs - ) - ] - HsApp exp1 exp2 -> do - -- TODO: if expDoc1 is some literal, we may want to create a docCols here. - expDoc1 <- docSharedWrapper layoutExpr exp1 - expDoc2 <- docSharedWrapper layoutExpr exp2 - docAlt - [ -- func arg - docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] - , -- func argline1 - -- arglines - -- e.g. - -- func if x - -- then 1 - -- else 2 - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docForceSingleline expDoc1 - , docForceParSpacing expDoc2 - ] - , -- func - -- arg - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline expDoc1) - (docNonBottomSpacing expDoc2) - , -- fu - -- nc - -- ar - -- gument - docAddBaseY BrIndentRegular - $ docPar - expDoc1 - expDoc2 - ] + HsLam{} -> + unknownNodeError "HsLam too complex" lexpr #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ - HsAppType exp1 (HsWC _ ty1) -> do + HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do #else /* ghc-8.0 */ - HsAppType exp1 (HsWC _ _ ty1) -> do + HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do #endif - t <- docSharedWrapper layoutType ty1 - e <- docSharedWrapper layoutExpr exp1 - docAlt - [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar - e - (docSeq [docLit $ Text.pack "@", t ]) - ] - HsAppTypeOut{} -> do - -- TODO - briDocByExactInlineOnly "HsAppTypeOut{}" lexpr - OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do - let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)]) - gather opExprList = \case - (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft - leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight - let allowPar = case (expOp, expRight) of - (L _ (HsVar (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ (L _ HsVar{}))) -> False - _ -> True - docAlt - [ docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - ) - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - -- this case rather leads to some unfortunate layouting than to anything - -- useful; disabling for now. (it interfers with cols stuff.) - -- , docSetBaseY - -- - $ docPar - -- leftOperandDoc - -- ( docLines - -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - -- ) - , docPar - leftOperandDoc - ( docLines - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - ) - ] - OpApp expLeft expOp _ expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp - expDocRight <- docSharedWrapper layoutExpr expRight - let allowPar = case (expOp, expRight) of - (L _ (HsVar (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ (L _ HsVar{}))) -> False - _ -> True - docAltFilter - $ [ -- one-line - (,) True - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceSingleline expDocRight - ] - -- , -- line + freely indented block for right expression - -- docSeq - -- [ appSep $ docForceSingleline expDocLeft - -- , appSep $ docForceSingleline expDocOp - -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight - -- ] - , -- two-line - (,) True + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "\\case") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + HsApp exp1@(L _ HsApp{}) exp2 -> do + let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) + gather list = \case + (L _ (HsApp l r)) -> gather (r:list) l + x -> (x, list) + let (headE, paramEs) = gather [exp2] exp1 + headDoc <- docSharedWrapper layoutExpr headE + paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs + docAlt + [ -- foo x y + docCols ColApp + $ appSep (docForceSingleline headDoc) + : spacifyDocs (docForceSingleline <$> paramDocs) + , -- foo x + -- y + docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - ( docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - ) - , -- one-line + par - (,) allowPar - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceParSpacing expDocRight + $ docLines + $ (docForceSingleline <$> paramDocs) + ] + , -- foo + -- x + -- y + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docForceSingleline headDoc) + ( docNonBottomSpacing + $ docLines paramDocs + ) + , -- ( multi + -- line + -- function + -- ) + -- x + -- y + docAddBaseY BrIndentRegular + $ docPar + headDoc + ( docNonBottomSpacing + $ docLines paramDocs + ) + ] + HsApp exp1 exp2 -> do + -- TODO: if expDoc1 is some literal, we may want to create a docCols here. + expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc2 <- docSharedWrapper layoutExpr exp2 + docAlt + [ -- func arg + docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + , -- func argline1 + -- arglines + -- e.g. + -- func if x + -- then 1 + -- else 2 + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docForceSingleline expDoc1 + , docForceParSpacing expDoc2 + ] + , -- func + -- arg + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docForceSingleline expDoc1) + (docNonBottomSpacing expDoc2) + , -- fu + -- nc + -- ar + -- gument + docAddBaseY BrIndentRegular + $ docPar + expDoc1 + expDoc2 + ] +#if MIN_VERSION_ghc(8,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 + [ docSeq + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t ] - , -- more lines - (,) True - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) + , docPar + e + (docSeq [docLit $ Text.pack "@", t ]) + ] + HsAppTypeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsAppTypeOut{}" lexpr + OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do + let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)]) + gather opExprList = \case + (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft + leftOperandDoc <- docSharedWrapper layoutExpr leftOperand + appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight + let allowPar = case (expOp, expRight) of + (L _ (HsVar (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ (L _ HsVar{}))) -> False + _ -> True + docAlt + [ docSeq + [ appSep $ docForceSingleline leftOperandDoc + , docSeq + $ (appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] + ) + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc ] - NegApp op _ -> do - opDoc <- docSharedWrapper layoutExpr op - docSeq $ [ docLit $ Text.pack "-" - , opDoc - ] - HsPar innerExp -> do - innerExpDoc <- docSharedWrapper layoutExpr innerExp - docAlt - [ docSeq - [ docLit $ Text.pack "(" - , docForceSingleline innerExpDoc - , docLit $ Text.pack ")" + -- this case rather leads to some unfortunate layouting than to anything + -- useful; disabling for now. (it interfers with cols stuff.) + -- , docSetBaseY + -- - $ docPar + -- leftOperandDoc + -- ( docLines + -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + -- ) + , docPar + leftOperandDoc + ( docLines + $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) ] - , docSetBaseY $ docLines - [ docCols ColOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) innerExpDoc - ] - , docLit $ Text.pack ")" - ] - ] - SectionL left op -> do -- TODO: add to testsuite - leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op - docSeq [leftDoc, opDoc] - SectionR op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op - rightDoc <- docSharedWrapper layoutExpr right - docSeq [opDoc, rightDoc] - ExplicitTuple args boxity - | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do - argDocs <- docSharedWrapper layoutExpr `mapM` argExprs - hasComments <- hasAnyCommentsBelow lexpr - let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)") - case splitFirstLast argDocs of - FirstLastEmpty -> docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit - ] - FirstLastSingleton e -> docAlt - [ docCols ColTuple - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - , closeLit + OpApp expLeft expOp _ expRight -> do + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp + expDocRight <- docSharedWrapper layoutExpr expRight + let allowPar = case (expOp, expRight) of + (L _ (HsVar (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ (L _ HsVar{}))) -> False + _ -> True + docAltFilter + $ [ -- one-line + (,) True + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceSingleline expDocRight + ] + -- , -- line + freely indented block for right expression + -- docSeq + -- [ appSep $ docForceSingleline expDocLeft + -- , appSep $ docForceSingleline expDocOp + -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight + -- ] + , -- two-line + (,) True + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + ( docForceSingleline + $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + ) + , -- one-line + par + (,) allowPar + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceParSpacing expDocRight + ] + , -- more lines + (,) True + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) + ] + NegApp op _ -> do + opDoc <- docSharedWrapper layoutExpr op + docSeq $ [ docLit $ Text.pack "-" + , opDoc + ] + HsPar innerExp -> do + innerExpDoc <- docSharedWrapper layoutExpr innerExp + docAlt + [ docSeq + [ docLit $ Text.pack "(" + , docForceSingleline innerExpDoc + , docLit $ Text.pack ")" ] , docSetBaseY $ docLines - [ docSeq + [ docCols ColOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) innerExpDoc + ] + , docLit $ Text.pack ")" + ] + ] + SectionL left op -> do -- TODO: add to testsuite + leftDoc <- docSharedWrapper layoutExpr left + opDoc <- docSharedWrapper layoutExpr op + docSeq [leftDoc, opDoc] + SectionR op right -> do -- TODO: add to testsuite + opDoc <- docSharedWrapper layoutExpr op + rightDoc <- docSharedWrapper layoutExpr right + docSeq [opDoc, rightDoc] + ExplicitTuple args boxity + | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do + argDocs <- docSharedWrapper layoutExpr `mapM` argExprs + hasComments <- hasAnyCommentsBelow lexpr + let (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)") + case splitFirstLast argDocs of + FirstLastEmpty -> docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit + ] + FirstLastSingleton e -> docAlt + [ docCols ColTuple [ openLit , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + , closeLit + ] + , docSetBaseY $ docLines + [ docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + ] + , closeLit ] - , closeLit ] - ] - FirstLast e1 ems eN -> - docAltFilter - [ (,) (not hasComments) - $ docCols ColTuple - ( [docSeq [openLit, docForceSingleline e1]] - ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + FirstLast e1 ems eN -> + docAltFilter + [ (,) (not hasComments) + $ docCols ColTuple + ( [docSeq [openLit, docForceSingleline e1]] + ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) + ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + ) + , (,) True + $ let + start = docCols ColTuples + [appSep $ openLit, e1] + linesM = ems <&> \d -> + docCols ColTuples [docCommaSep, d] + lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ] + ExplicitTuple{} -> + unknownNodeError "ExplicitTuple|.." lexpr + HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do + cExpDoc <- docSharedWrapper layoutExpr cExp + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + docAlt + [ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of" + ]) + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "of") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) - , (,) True - $ let - start = docCols ColTuples - [appSep $ openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] - ExplicitTuple{} -> - unknownNodeError "ExplicitTuple|.." lexpr - HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches - docAlt - [ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of" - ]) - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "of") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - ) - ] - HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr - thenExprDoc <- docSharedWrapper layoutExpr thenExpr - elseExprDoc <- docSharedWrapper layoutExpr elseExpr - hasComments <- hasAnyCommentsBelow lexpr - docAltFilter - [ -- if _ then _ else _ - (,) (not hasComments) - $ docSeq - [ appSep $ docLit $ Text.pack "if" - , appSep $ docForceSingleline ifExprDoc - , appSep $ docLit $ Text.pack "then" - , appSep $ docForceSingleline thenExprDoc - , appSep $ docLit $ Text.pack "else" - , docForceSingleline elseExprDoc ] - , -- either - -- if expr - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if expr - -- then - -- stuff - -- else - -- stuff - -- note that this has par-spacing - (,) True - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY (BrIndentSpecial 3) - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + HsIf _ ifExpr thenExpr elseExpr -> do + ifExprDoc <- docSharedWrapper layoutExpr ifExpr + thenExprDoc <- docSharedWrapper layoutExpr thenExpr + elseExprDoc <- docSharedWrapper layoutExpr elseExpr + hasComments <- hasAnyCommentsBelow lexpr + docAltFilter + [ -- if _ then _ else _ + (,) (not hasComments) + $ docSeq + [ appSep $ docLit $ Text.pack "if" + , appSep $ docForceSingleline ifExprDoc + , appSep $ docLit $ Text.pack "then" + , appSep $ docForceSingleline thenExprDoc + , appSep $ docLit $ Text.pack "else" + , docForceSingleline elseExprDoc + ] + , -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + (,) True + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY (BrIndentSpecial 3) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + , -- either + -- if multi + -- line + -- condition + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if multi + -- line + -- condition + -- then + -- stuff + -- else + -- stuff + -- note that this does _not_ have par-spacing + (,) True + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY (BrIndentSpecial 3) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - , -- either - -- if multi - -- line - -- condition - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if multi - -- line - -- condition - -- then - -- stuff - -- else - -- stuff - -- note that this does _not_ have par-spacing - (,) True - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY (BrIndentSpecial 3) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + , (,) True + $ docSetBaseY + $ docLines + [ docAddBaseY (BrIndentSpecial 3) $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ] + HsMultiIf _ cases -> do + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" + hasComments <- hasAnyCommentsBelow lexpr + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "if") + (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) + HsLet binds exp1 -> do + expDoc1 <- docSharedWrapper layoutExpr exp1 + mBindDocs <- layoutLocalBinds binds + -- this `docSetIndentLevel` might seem out of place, but is here due to + -- ghc-exactprint's DP handling of "let" in particular. + -- Just pushing another indentation level is a straightforward approach + -- to making brittany idempotent, even though the result is non-optimal + -- if "let" is moved horizontally as part of the transformation, as the + -- comments before the first let item are moved horizontally with it. + docSetIndentLevel $ case mBindDocs of + Just [bindDoc] -> docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , appSep $ docForceSingleline $ return bindDoc + , appSep $ docLit $ Text.pack "in" + , docForceSingleline $ expDoc1 + ] + , docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ return bindDoc + ] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 + ] + ] + , docLines [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] + $ docPar + (appSep $ docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc + $ docPar + (appSep $ docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] + ] + Just bindDocs@(_:_) -> docAlt + [ docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs ] - ]) - , (,) True - $ docSetBaseY - $ docLines - [ docAddBaseY (BrIndentSpecial 3) - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 + ] + ] + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] ] - , docNodeAnnKW lexpr (Just AnnThen) + _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] + -- docSeq [appSep $ docLit "let in", expDoc1] + HsDo DoExpr (L _ stmts) _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ] - HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" - hasComments <- hasAnyCommentsBelow lexpr - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "if") - (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) - HsLet binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 - mBindDocs <- layoutLocalBinds binds - -- this `docSetIndentLevel` might seem out of place, but is here due to - -- ghc-exactprint's DP handling of "let" in particular. - -- Just pushing another indentation level is a straightforward approach - -- to making brittany idempotent, even though the result is non-optimal - -- if "let" is moved horizontally as part of the transformation, as the - -- comments before the first let item are moved horizontally with it. - docSetIndentLevel $ case mBindDocs of - Just [bindDoc] -> docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline $ return bindDoc - , appSep $ docLit $ Text.pack "in" - , docForceSingleline $ expDoc1 - ] - , docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ return bindDoc - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 - ] - ] - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (appSep $ docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - , docAddBaseY BrIndentRegular - $ docPar - (appSep $ docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + HsDo MDoExpr (L _ stmts) _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + HsDo x (L _ stmts) _ | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + docAltFilter + [ (,) (not hasComments) + $ docSeq + [ docNodeAnnKW lexpr Nothing + $ appSep + $ docLit + $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq $ List.intersperse docCommaSep + $ fmap docForceSingleline $ List.init stmtDocs + , docLit $ Text.pack " ]" ] + , (,) True + $ let + start = docCols ColListComp + [ docNodeAnnKW lexpr Nothing + $ appSep $ docLit $ Text.pack "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1:sM) = List.init stmtDocs + line1 = docCols ColListComp + [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] ] - Just bindDocs@(_:_) -> docAlt - [ docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 - ] - ] - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) - ] - ] - _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] - -- docSeq [appSep $ docLit "let in", expDoc1] - HsDo DoExpr (L _ stmts) _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - HsDo MDoExpr (L _ stmts) _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - HsDo x (L _ stmts) _ | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - docAltFilter - [ (,) (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ fmap docForceSingleline $ List.init stmtDocs - , docLit $ Text.pack " ]" - ] - , (,) True - $ let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - ] - HsDo{} -> do - -- TODO - unknownNodeError "HsDo{} no comp" lexpr - ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr - hasComments <- hasAnyCommentsBelow lexpr - case splitFirstLast elemDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq + HsDo{} -> do + -- TODO + unknownNodeError "HsDo{} no comp" lexpr + ExplicitList _ _ elems@(_:_) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr + hasComments <- hasAnyCommentsBelow lexpr + case splitFirstLast elemDocs of + FirstLastEmpty -> docSeq [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" + , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" ] - , docSetBaseY $ docLines + FirstLastSingleton e -> docAlt [ docSeq [ docLit $ Text.pack "[" - , docSeparator - , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e + , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "[" + , docSeparator + , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e + ] + , docLit $ Text.pack "]" ] - , docLit $ Text.pack "]" ] - ] - FirstLast e1 ems eN -> - docAltFilter - [ (,) (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) - ++ [docLit $ Text.pack "]"] - , (,) True - $ let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] - ExplicitList _ _ [] -> - docLit $ Text.pack "[]" - ExplicitPArr{} -> do - -- TODO - briDocByExactInlineOnly "ExplicitPArr{}" lexpr - RecordCon lname _ _ (HsRecFields [] Nothing) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{" - , docLit $ Text.pack "}" - ] - RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return $ (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 appender wrapper = - [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper $ x - ] - Nothing -> docEmpty - ] - let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , wrapper x - ] - Nothing -> docEmpty - ] - let lineN = - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - docAlt - [ docSeq - $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] - ++ line1 id docForceSingleline - ++ join (lineR docForceSingleline) - ++ lineN - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing $ nameDoc) - ( docNonBottomSpacing - $ docLines - $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] - ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) - ++ [docSeq lineN] - ) - ] - RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " {..}" - RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return $ (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 appender wrapper = - [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper $ x - ] - Nothing -> docEmpty - ] - let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , wrapper x - ] - Nothing -> docEmpty - ] - let lineDot = - [ docCommaSep - , docLit $ Text.pack ".." - ] - let lineN = - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - docAlt - [ docSeq - $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] - ++ line1 id docForceSingleline - ++ join (lineR docForceSingleline) - ++ lineDot - ++ lineN - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing $ nameDoc) - ( docNonBottomSpacing - $ docLines - $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] - ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) - ++ [docSeq lineDot, docSeq lineN] - ) - ] - RecordCon{} -> - unknownNodeError "RecordCon with puns" lexpr - RecordUpd rExpr [] _ _ _ _ -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - docSeq [rExprDoc, docLit $ Text.pack "{}"] - RecordUpd rExpr fields@(_:_) _ _ _ _ -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs@((rF1f, rF1n, rF1e):rFr) <- fields - `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ case ambName of - Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - docAlt - -- singleline - [ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc - , appSep $ docLit $ Text.pack "{" - , appSep $ docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr + FirstLast e1 ems eN -> + docAltFilter + [ (,) (not hasComments) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) + ++ [docLit $ Text.pack "]"] + , (,) True + $ let + start = docCols ColList + [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> + docCols ColList [docCommaSep, d] + lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ] + ExplicitList _ _ [] -> + docLit $ Text.pack "[]" + ExplicitPArr{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitPArr{}" lexpr + RecordCon lname _ _ (HsRecFields [] Nothing) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{" , docLit $ Text.pack "}" ] - -- wild-indentation block - , docSeq - [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline $ x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] + RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + let line1 appender wrapper = + [ appender $ docLit $ Text.pack "{" + , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , case fd1e of + Just x -> docSeq + [ appSep $ docLit $ Text.pack "=" + , docWrapNodeRest fd1l $ wrapper $ x + ] + Nothing -> docEmpty + ] + let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docWrapNode lfield $ docSeq + [ appSep $ docLit $ Text.pack "=" + , wrapper x + ] + Nothing -> docEmpty + ] + let lineN = + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + docAlt + [ docSeq + $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + ++ line1 id docForceSingleline + ++ join (lineR docForceSingleline) + ++ lineN + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing $ nameDoc) + ( docNonBottomSpacing + $ docLines + $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] + ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) + ++ [docSeq lineN] + ) + ] + RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " {..}" + RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + let line1 appender wrapper = + [ appender $ docLit $ Text.pack "{" + , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , case fd1e of + Just x -> docSeq + [ appSep $ docLit $ Text.pack "=" + , docWrapNodeRest fd1l $ wrapper $ x + ] + Nothing -> docEmpty + ] + let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docWrapNode lfield $ docSeq + [ appSep $ docLit $ Text.pack "=" + , wrapper x + ] + Nothing -> docEmpty + ] + let lineDot = + [ docCommaSep + , docLit $ Text.pack ".." + ] + let lineN = + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + docAlt + [ docSeq + $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + ++ line1 id docForceSingleline + ++ join (lineR docForceSingleline) + ++ lineDot + ++ lineN + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing $ nameDoc) + ( docNonBottomSpacing + $ docLines + $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] + ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) + ++ [docSeq lineDot, docSeq lineN] + ) + ] + RecordCon{} -> + unknownNodeError "RecordCon with puns" lexpr + RecordUpd rExpr [] _ _ _ _ -> do + rExprDoc <- docSharedWrapper layoutExpr rExpr + docSeq [rExprDoc, docLit $ Text.pack "{}"] + RecordUpd rExpr fields@(_:_) _ _ _ _ -> do + rExprDoc <- docSharedWrapper layoutExpr rExpr + rFs@((rF1f, rF1n, rF1e):rFr) <- fields + `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ case ambName of + Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) + docAlt + -- singleline + [ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc + , appSep $ docLit $ Text.pack "{" + , appSep $ docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , docLit $ Text.pack "}" + ] + -- wild-indentation block + , docSeq + [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline $ x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ] + -- strict indentation block + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing $ rExprDoc) + (docNonBottomSpacing $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular $ x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN]) ] - -- strict indentation block - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing $ rExprDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular $ x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN]) - ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ - ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do + ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #else /* ghc-8.0 */ - ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do + ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do #endif - expDoc <- docSharedWrapper layoutExpr exp1 - typDoc <- docSharedWrapper layoutType typ1 - docSeq - [ appSep expDoc - , appSep $ docLit $ Text.pack "::" - , typDoc - ] - ExprWithTySigOut{} -> do - -- TODO - briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr - ArithSeq _ Nothing info -> - case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , docCommaSep - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , docCommaSep - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> - briDocByExactInlineOnly "ArithSeq" lexpr - PArrSeq{} -> do - -- TODO - briDocByExactInlineOnly "PArrSeq{}" lexpr - HsSCC{} -> do - -- TODO - briDocByExactInlineOnly "HsSCC{}" lexpr - HsCoreAnn{} -> do - -- TODO - briDocByExactInlineOnly "HsCoreAnn{}" lexpr - HsBracket{} -> do - -- TODO - briDocByExactInlineOnly "HsBracket{}" lexpr - HsRnBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsRnBracketOut{}" lexpr - HsTcBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsTcBracketOut{}" lexpr - HsSpliceE{} -> do - -- TODO - briDocByExactInlineOnly "HsSpliceE{}" lexpr - HsProc{} -> do - -- TODO - briDocByExactInlineOnly "HsProc{}" lexpr - HsStatic{} -> do - -- TODO - briDocByExactInlineOnly "HsStatic{}" lexpr - HsArrApp{} -> do - -- TODO - briDocByExactInlineOnly "HsArrApp{}" lexpr - HsArrForm{} -> do - -- TODO - briDocByExactInlineOnly "HsArrForm{}" lexpr - HsTick{} -> do - -- TODO - briDocByExactInlineOnly "HsTick{}" lexpr - HsBinTick{} -> do - -- TODO - briDocByExactInlineOnly "HsBinTick{}" lexpr - HsTickPragma{} -> do - -- TODO - briDocByExactInlineOnly "HsTickPragma{}" lexpr - EWildPat{} -> do - docLit $ Text.pack "_" - EAsPat asName asExpr -> do - docSeq - [ docLit $ (lrdrNameToText asName) <> Text.pack "@" - , layoutExpr asExpr - ] - EViewPat{} -> do - -- TODO - briDocByExactInlineOnly "EViewPat{}" lexpr - ELazyPat{} -> do - -- TODO - briDocByExactInlineOnly "ELazyPat{}" lexpr - HsWrap{} -> do - -- TODO - briDocByExactInlineOnly "HsWrap{}" lexpr + expDoc <- docSharedWrapper layoutExpr exp1 + typDoc <- docSharedWrapper layoutType typ1 + docSeq + [ appSep expDoc + , appSep $ docLit $ Text.pack "::" + , typDoc + ] + ExprWithTySigOut{} -> do + -- TODO + briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr + ArithSeq _ Nothing info -> + case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , docCommaSep + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , docCommaSep + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> + briDocByExactInlineOnly "ArithSeq" lexpr + PArrSeq{} -> do + -- TODO + briDocByExactInlineOnly "PArrSeq{}" lexpr + HsSCC{} -> do + -- TODO + briDocByExactInlineOnly "HsSCC{}" lexpr + HsCoreAnn{} -> do + -- TODO + briDocByExactInlineOnly "HsCoreAnn{}" lexpr + HsBracket{} -> do + -- TODO + briDocByExactInlineOnly "HsBracket{}" lexpr + HsRnBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsRnBracketOut{}" lexpr + HsTcBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsTcBracketOut{}" lexpr + HsSpliceE{} -> do + -- TODO + briDocByExactInlineOnly "HsSpliceE{}" lexpr + HsProc{} -> do + -- TODO + briDocByExactInlineOnly "HsProc{}" lexpr + HsStatic{} -> do + -- TODO + briDocByExactInlineOnly "HsStatic{}" lexpr + HsArrApp{} -> do + -- TODO + briDocByExactInlineOnly "HsArrApp{}" lexpr + HsArrForm{} -> do + -- TODO + briDocByExactInlineOnly "HsArrForm{}" lexpr + HsTick{} -> do + -- TODO + briDocByExactInlineOnly "HsTick{}" lexpr + HsBinTick{} -> do + -- TODO + briDocByExactInlineOnly "HsBinTick{}" lexpr + HsTickPragma{} -> do + -- TODO + briDocByExactInlineOnly "HsTickPragma{}" lexpr + EWildPat{} -> do + docLit $ Text.pack "_" + EAsPat asName asExpr -> do + docSeq + [ docLit $ (lrdrNameToText asName) <> Text.pack "@" + , layoutExpr asExpr + ] + EViewPat{} -> do + -- TODO + briDocByExactInlineOnly "EViewPat{}" lexpr + ELazyPat{} -> do + -- TODO + briDocByExactInlineOnly "ELazyPat{}" lexpr + 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 + HsConLikeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsWrap{}" lexpr + ExplicitSum{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitSum{}" lexpr #endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index a8d95aa..1187876 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -26,57 +26,58 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) -layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of - LastStmt body False _ -> do - layoutExpr body - BindStmt lPat expr _ _ _ -> do - patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docAlt - [ docCols - ColBindStmt - [ appSep patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] +layoutStmt lstmt@(L _ stmt) = do + docWrapNode lstmt $ case stmt of + LastStmt body False _ -> do + layoutExpr body + BindStmt lPat expr _ _ _ -> do + patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat + expDoc <- docSharedWrapper layoutExpr expr + docAlt + [ docCols + ColBindStmt + [ appSep patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] + ] + , docCols + ColBindStmt + [ appSep patDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "<-") (expDoc) + ] ] - , docCols - ColBindStmt - [ appSep patDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "<-") (expDoc) + LetStmt binds -> layoutLocalBinds binds >>= \case + Nothing -> docLit $ Text.pack "let" -- i just tested + -- it, and it is + -- indeed allowed. + -- heh. + Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [bindDoc] -> docAlt + [ docCols + ColDoLet + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ return bindDoc + ] + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) ] - ] - LetStmt binds -> layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" -- i just tested - -- it, and it is - -- indeed allowed. - -- heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAlt - [ docCols - ColDoLet - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ return bindDoc + Just bindDocs -> docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - ] - Just bindDocs -> docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs + RecStmt stmts _ _ _ _ _ _ _ _ _ -> do + docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - ] - RecStmt stmts _ _ _ _ _ _ _ _ _ -> do - docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] - BodyStmt expr _ _ _ -> do - expDoc <- docSharedWrapper layoutExpr expr - docAddBaseY BrIndentRegular $ expDoc - _ -> briDocByExactInlineOnly "some unknown statement" lstmt + BodyStmt expr _ _ _ -> do + expDoc <- docSharedWrapper layoutExpr expr + docAddBaseY BrIndentRegular $ expDoc + _ -> briDocByExactInlineOnly "some unknown statement" lstmt -- 2.30.2 From 88cbaf813a4b7910c19e83edb3ba22153c12e5c5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Sep 2017 23:27:21 +0200 Subject: [PATCH 018/478] Implement `IndentPolicyLeft` for one HsApp case --- .../Brittany/Internal/Layouters/Expr.hs | 57 ++++++++++++------- 1 file changed, 35 insertions(+), 22 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index fe82e3c..cd10792 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -32,6 +32,11 @@ import Language.Haskell.Brittany.Internal.Layouters.Type layoutExpr :: ToBriDoc HsExpr layoutExpr lexpr@(L _ expr) = do + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack + let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of HsVar vname -> do docLit =<< lrdrNameToTextAnn vname @@ -114,29 +119,35 @@ layoutExpr lexpr@(L _ expr) = do let (headE, paramEs) = gather [exp2] exp1 headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - docAlt + docAltFilter [ -- foo x y - docCols ColApp - $ appSep (docForceSingleline headDoc) - : spacifyDocs (docForceSingleline <$> paramDocs) + ( True + , docCols ColApp + $ appSep (docForceSingleline headDoc) + : spacifyDocs (docForceSingleline <$> paramDocs) + ) , -- foo x -- y - docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ (docForceSingleline <$> paramDocs) - ] + ( allowFreeIndent + , docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY + $ docAddBaseY BrIndentRegular + $ docLines + $ (docForceSingleline <$> paramDocs) + ] + ) , -- foo -- x -- y - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline headDoc) - ( docNonBottomSpacing - $ docLines paramDocs + ( True + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docForceSingleline headDoc) + ( docNonBottomSpacing + $ docLines paramDocs + ) ) , -- ( multi -- line @@ -144,11 +155,13 @@ layoutExpr lexpr@(L _ expr) = do -- ) -- x -- y - docAddBaseY BrIndentRegular - $ docPar - headDoc - ( docNonBottomSpacing - $ docLines paramDocs + ( True + , docAddBaseY BrIndentRegular + $ docPar + headDoc + ( docNonBottomSpacing + $ docLines paramDocs + ) ) ] HsApp exp1 exp2 -> do -- 2.30.2 From bdf876991334bf79e6768ce58c06dcfab7c03e3a Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Thu, 21 Sep 2017 21:44:10 -0400 Subject: [PATCH 019/478] Remove 3 space special case from HsIf when IndentPolicyLeft ``` if foo bar then baz ``` becomes ``` if foo bar then baz ``` --- .../Haskell/Brittany/Internal/Layouters/Expr.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index cd10792..66169d8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -415,6 +415,10 @@ layoutExpr lexpr@(L _ expr) = do thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr hasComments <- hasAnyCommentsBelow lexpr + let maySpecialIndent = + case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + _ -> BrIndentSpecial 3 docAltFilter [ -- if _ then _ else _ (,) (not hasComments) @@ -443,7 +447,7 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - ( docAddBaseY (BrIndentSpecial 3) + ( docAddBaseY maySpecialIndent $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc @@ -483,7 +487,7 @@ layoutExpr lexpr@(L _ expr) = do (,) True $ docAddBaseY BrIndentRegular $ docPar - ( docAddBaseY (BrIndentSpecial 3) + ( docAddBaseY maySpecialIndent $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc @@ -506,7 +510,7 @@ layoutExpr lexpr@(L _ expr) = do , (,) True $ docSetBaseY $ docLines - [ docAddBaseY (BrIndentSpecial 3) + [ docAddBaseY maySpecialIndent $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc -- 2.30.2 From ce41178df5b6dbec12b68d7eec3d743cccbda15e Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Thu, 21 Sep 2017 21:47:30 -0400 Subject: [PATCH 020/478] Remove context sensitive let indentation when IndentPolicyLeft Let expressions with multiple bindings automattically indent and pull left ``` let a = b c = d in foo bar baz ``` ``` let a = b c = d in foo bar baz ``` ``` let a = b c = d in foo bar baz ``` ``` let a = b c = d in foo bar baz ``` --- .../Brittany/Internal/Layouters/Expr.hs | 77 ++++++++++++++----- 1 file changed, 57 insertions(+), 20 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 66169d8..a56144e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -567,28 +567,65 @@ layoutExpr lexpr@(L _ expr) = do (docSetBaseY $ expDoc1) ] ] - Just bindDocs@(_:_) -> docAlt - [ docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs + Just bindDocs@(_:_) -> docAlt $ + case indentPolicy of + IndentPolicyLeft -> + --either + -- let + -- a = b + -- c = d + -- in foo + -- bar + -- baz + --or + -- let + -- a = b + -- c = d + -- in + -- fooooooooooooooooooo + [ docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ expDoc1 + ] + ] + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 + _ -> + [ docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 + ] + ] + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] ] - ] - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) - ] - ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo DoExpr (L _ stmts) _ -> do -- 2.30.2 From 3bbf81baabb05b1d1206f76851bc46529da73060 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 15:05:58 -0500 Subject: [PATCH 021/478] Add literate tests for context free formatting Left indent combined with no columnized alignment represents a context free formatting style for brittany. These tests allow this format to be tested until inline formatting tools are available to make these files less redundant. --- src-literatetests/Main.hs | 40 +- src-literatetests/tests-context-free.blt | 1109 ++++++++++++++++++++++ 2 files changed, 1140 insertions(+), 9 deletions(-) create mode 100644 src-literatetests/tests-context-free.blt diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 34b4e4e..938aca6 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -40,14 +40,27 @@ data InputLine main :: IO () main = do files <- System.Directory.listDirectory "src-literatetests/" - let blts = List.sort $ filter (".blt" `isSuffixOf`) files + let blts = + List.sort + $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) + $ filter (".blt"`isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) let groups = createChunks =<< inputs - hspec $ groups `forM_` \(groupname, tests) -> do - describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do - (if pend then before_ pending else id) - $ it (Text.unpack name) - $ roundTripEqual inp + inputCtxFree <- Text.IO.readFile "src-literatetests/tests-context-free.blt" + let groupsCtxFree = createChunks inputCtxFree + hspec $ do + groups `forM_` \(groupname, tests) -> do + describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do + (if pend then before_ pending else id) + $ it (Text.unpack name) + $ roundTripEqual defaultTestConfig inp + groupsCtxFree `forM_` \(groupname, tests) -> do + describe ("context free: " ++ Text.unpack groupname) + $ tests + `forM_` \(name, pend, inp) -> do + (if pend then before_ pending else id) + $ it (Text.unpack name) + $ roundTripEqual contextFreeTestConfig inp where -- this function might be implemented in a weirdly complex fashion; the -- reason being that it was copied from a somewhat more complex variant. @@ -132,10 +145,10 @@ main = do -------------------- -- past this line: copy-pasta from other test (meh..) -------------------- -roundTripEqual :: Text -> Expectation -roundTripEqual t = +roundTripEqual :: Config -> Text -> Expectation +roundTripEqual c t = fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + (parsePrintModuleTests c "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text @@ -170,3 +183,12 @@ defaultTestConfig = Config } } +contextFreeTestConfig :: Config +contextFreeTestConfig = + defaultTestConfig + { _conf_layout = (_conf_layout defaultTestConfig) + {_lconfig_indentPolicy = coerce IndentPolicyLeft + ,_lconfig_alignmentLimit = coerce (1 :: Int) + ,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled + } + } diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt new file mode 100644 index 0000000..e126dde --- /dev/null +++ b/src-literatetests/tests-context-free.blt @@ -0,0 +1,1109 @@ + +############################################################################### +############################################################################### +############################################################################### +#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 let-defs no indent +func = do + let + foo True = True + foo _ = False + return () + +#test let-defs no indent +func = do + let + foo = True + b = False + return () + +#test let-defs no indent +func = + let + foo = True + b = False + in return () + +#test record update indentation 1 +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +#test record update indentation 2 +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state + , _lstate_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" + -- 2.30.2 From de5f0401f3ffaab397370cd60227d7086fc7a703 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 15:08:11 -0500 Subject: [PATCH 022/478] Add consistency between contsrained and unconstrained forall format Constrained forall formats aligned the `.` to the left. Constrained formats aligned the `.` to the right. This change adds consistency between both formats. --- .../Haskell/Brittany/Internal/Layouters/Type.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index a5148f5..bd4d728 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -174,17 +174,17 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docForceSingleline $ return $ typeDoc ] -- :: forall x - -- . x + -- . x , docPar (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ". " + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " , maybeForceML $ return typeDoc ] ) -- :: forall -- (x :: *) - -- . x + -- . x , docPar (docLit (Text.pack "forall")) (docLines @@ -204,7 +204,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ++[ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ". " + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " , maybeForceML $ return typeDoc ] ] @@ -499,7 +499,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ) (docCols ColTyOpPrefix [ docWrapNodeRest ltype - $ docLit $ Text.pack "::" + $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 2) typeDoc1 ]) ] -- 2.30.2 From a13a137f681ccb5ee2d202faaee2cc2282163076 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 15:09:29 -0500 Subject: [PATCH 023/478] Add left indent support for statements This aligns left indent style `let` statements with their expression form. --- .../Brittany/Internal/Layouters/Stmt.hs | 22 +++++++++++-------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 1187876..6f95585 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -11,6 +11,7 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) @@ -27,6 +28,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) layoutStmt lstmt@(L _ stmt) = do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack docWrapNode lstmt $ case stmt of LastStmt body False _ -> do layoutExpr body @@ -62,15 +64,17 @@ layoutStmt lstmt@(L _ stmt) = do (docLit $ Text.pack "let") (docSetBaseAndIndent $ return bindDoc) ] - Just bindDocs -> docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs - ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - ] + Just bindDocs -> + let letSeq = docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + letRegular = docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + in case indentPolicy of + IndentPolicyLeft -> docAlt [letRegular] + _ -> docAlt [letSeq, letRegular] RecStmt stmts _ _ _ _ _ _ _ _ _ -> do docSeq [ docLit (Text.pack "rec") -- 2.30.2 From cd9f7de56645f8b0fcc8b2ded71a66fe5b6cbdb6 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 15:18:41 -0500 Subject: [PATCH 024/478] Update pending type operator test for context free. --- src-literatetests/tests-context-free.blt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index e126dde..9529bee 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -198,12 +198,12 @@ func #test type operator stuff #pending test050 :: a :+: b -test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd +test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd +test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd ############################################################################### -- 2.30.2 From f3c37a6abf3ebeb6c92c31622294788d9f34bc9b Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 15:20:41 -0500 Subject: [PATCH 025/478] Update pending long argument test to context free. --- src-literatetests/tests-context-free.blt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 9529bee..11e1bee 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -350,14 +350,14 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable #test simple multiline pattern #pending func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = x #test another multiline pattern #pending func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - a - b + a + b = x #test simple constructor -- 2.30.2 From d1e19842066d859504e7d9d348936d98ef8c1d23 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 15:50:54 -0500 Subject: [PATCH 026/478] Update guard formatting for IndentPolicyLeft --- src-literatetests/tests-context-free.blt | 10 ++-- .../Brittany/Internal/Layouters/Decl.hs | 47 ++++++++++++++----- 2 files changed, 42 insertions(+), 15 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 11e1bee..be8a8c9 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -382,8 +382,9 @@ func (x:+:xr) = x func | True = x #test multiple-clauses-1 -func x | x = simple expression - | otherwise = 0 +func x + | x = simple expression + | otherwise = 0 #test multiple-clauses-2 func x @@ -845,8 +846,9 @@ showPackageDetailedInfo pkginfo = ] #test issue 7a -isValidPosition position | validX && validY = Just position - | otherwise = Nothing +isValidPosition position + | validX && validY = Just position + | otherwise = Nothing #test issue-6-pattern-linebreak-validity ## this is ugly, but at least syntactically valid. diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 5073eab..30e26c2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -265,9 +265,15 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) - docAlt + + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack + docAltFilter $ -- one-line solution - [ docCols + [ ( True + , docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq @@ -276,6 +282,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha , wherePart ] ] + ) | not hasComments , [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards @@ -289,7 +296,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha _ -> [] ] ++ -- one-line solution + where in next line(s) - [ docLines + [ ( True + , docLines $ [ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) @@ -298,23 +306,27 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + ) | [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards , Data.Maybe.isJust mWhereDocs ] ++ -- two-line solution + where in next line(s) - [ docLines + [ ( True + , docLines $ [ docForceSingleline $ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body ] ++ wherePartMultiLine + ) | [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards ] ++ -- pattern and exactly one clause in single line, body as par; -- where in following lines - [ docLines + [ ( True + , docLines $ [ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) @@ -329,24 +341,28 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha -- , docAddBaseY BrIndentRegular $ return body -- ] ++ wherePartMultiLine + ) | [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards ] ++ -- pattern and exactly one clause in single line, body in new line. - [ docLines + [ ( True + , docLines $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docEnsureIndent BrIndentRegular $ docNonBottomSpacing $ (docAddBaseY BrIndentRegular $ return body) ] ++ wherePartMultiLine + ) | [(guards, body, _)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards ] ++ -- multiple clauses added in-paragraph, each in a single line -- example: foo | bar = baz -- | lll = asd - [ docLines + [ ( indentPolicy /= IndentPolicyLeft + , docLines $ [ docSeq [ appSep $ docForceSingleline $ return patDoc , docSetBaseY @@ -370,10 +386,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + ) | Just patDoc <- [mPatDoc] ] ++ -- multiple clauses, each in a separate, single line - [ docLines + [ ( True + , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines @@ -396,10 +414,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + ) ] ++ -- multiple clauses, each with the guard(s) in a single line, body -- as a paragraph - [ docLines + [ ( True + , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines @@ -431,10 +451,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + ) ] ++ -- multiple clauses, each with the guard(s) in a single line, body -- in a new line as a paragraph - [ docLines + [ ( True + , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines @@ -464,9 +486,11 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + ) ] ++ -- conservative approach: everything starts on the left. - [ docLines + [ ( True + , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines @@ -494,4 +518,5 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + ) ] -- 2.30.2 From a6bea7542b098a319b488a2b596af4df8ac9ac51 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 15:53:31 -0500 Subject: [PATCH 027/478] Update pending long operator use for left indent. --- src-literatetests/tests-context-free.blt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index be8a8c9..71c6809 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -434,19 +434,19 @@ func = x + x #test long #pending func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj #test long keep linemode 1 #pending func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj #test long keep linemode 2 #pending func = mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj #test literals func = 1 -- 2.30.2 From 44e95940c0ff98b82f533f6b1c1fbb06899f4113 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 16:03:29 -0500 Subject: [PATCH 028/478] Change record update syntax for left indent policy --- src-literatetests/tests-context-free.blt | 13 +- .../Brittany/Internal/Layouters/Expr.hs | 150 +++++++++--------- 2 files changed, 85 insertions(+), 78 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 71c6809..58b6406 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -646,9 +646,10 @@ func = do #test record update indentation 2 func = do s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state - , _lstate_indent = _lstate_indent state - } + mSet $ s + { _lstate_indent = _lstate_indent state + , _lstate_indent = _lstate_indent state + } #test record update indentation 3 func = do @@ -972,9 +973,9 @@ runBrittany tabSize text = do let config' = staticDefaultConfig config = config' - { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce - tabSize - } + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } , _conf_forward = forwardOptionsSyntaxExtsEnabled } parsePrintModule config text diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a56144e..86e86ac 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -853,81 +853,87 @@ layoutExpr lexpr@(L _ expr) = do return $ case ambName of Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - docAlt + docAltFilter -- singleline - [ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc - , appSep $ docLit $ Text.pack "{" - , appSep $ docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr - , docLit $ Text.pack "}" - ] + [ ( True + , docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc + , appSep $ docLit $ Text.pack "{" + , appSep $ docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , docLit $ Text.pack "}" + ] + ) -- wild-indentation block - , docSeq - [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline $ x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x + , ( indentPolicy /= IndentPolicyLeft + , docSeq + [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline $ x ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] - ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ] + ) -- strict indentation block - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing $ rExprDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular $ x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular x + , ( True + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing $ rExprDoc) + (docNonBottomSpacing $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular $ x ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN]) + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN]) + ) ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do @@ -959,7 +965,7 @@ layoutExpr lexpr@(L _ expr) = do docSeq [ docLit $ Text.pack "[" , docForceSingleline e1Doc - , docCommaSep + , appSep $ docLit $ Text.pack "," , appSep $ docForceSingleline e2Doc , docLit $ Text.pack "..]" ] @@ -980,7 +986,7 @@ layoutExpr lexpr@(L _ expr) = do docSeq [ docLit $ Text.pack "[" , docForceSingleline e1Doc - , docCommaSep + , appSep $ docLit $ Text.pack "," , appSep $ docForceSingleline e2Doc , appSep $ docLit $ Text.pack ".." , docForceSingleline eNDoc -- 2.30.2 From d7ac478fc66662bcdc7eba80c4d1478b932f3490 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 16:11:28 -0500 Subject: [PATCH 029/478] Update type operator pending tests to remove context. --- src-literatetests/tests-context-free.blt | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 58b6406..6865862 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -198,12 +198,14 @@ func #test type operator stuff #pending test050 :: a :+: b -test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd +test051 + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd +test052 + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd ############################################################################### -- 2.30.2 From ba3d9ad7393b57f69b5b7df76132dd156153f842 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 19 Nov 2017 17:36:29 -0500 Subject: [PATCH 030/478] Add tests for record construction. --- src-literatetests/15-regressions.blt | 20 ++++++++++++++++++-- src-literatetests/tests-context-free.blt | 22 ++++++++++++++++++++-- 2 files changed, 38 insertions(+), 4 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index bea97cc..b521072 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -31,7 +31,7 @@ func = do func = do s <- mGet mSet $ s { _lstate_indent = _lstate_indent state - , _lstate_indent = _lstate_indent state + , _lstate_foo = _lstate_foo state } #test record update indentation 3 @@ -39,7 +39,23 @@ func = do s <- mGet mSet $ s { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } + +#test record construction 1 +func = Foo {_lstate_indent = _lstate_indent state} + +#test record construction 2 +func = Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_fooo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } + +#test record construction 3 +func = do + Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd } #test post-indent comment diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 6865862..f5ab85c 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -650,7 +650,7 @@ func = do s <- mGet mSet $ s { _lstate_indent = _lstate_indent state - , _lstate_indent = _lstate_indent state + , _lstate_foo = _lstate_foo state } #test record update indentation 3 @@ -658,7 +658,25 @@ func = do s <- mGet mSet $ s { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo kasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } + +#test record construction 1 +func = Foo + { _lstate_indent = _lstate_indent state + } + +#test record construction 2 +func = Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } + +#test record construction 3 +func = do + Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd } #test post-indent comment -- 2.30.2 From 35f33c131cea6e9918dda0d937c997cf7aea8a3d Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sat, 25 Nov 2017 20:24:41 -0500 Subject: [PATCH 031/478] Remove duplication in 'let' expression layout. --- .../Brittany/Internal/Layouters/Expr.hs | 100 ++++++++---------- 1 file changed, 46 insertions(+), 54 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 86e86ac..c3f4429 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -567,65 +567,57 @@ layoutExpr lexpr@(L _ expr) = do (docSetBaseY $ expDoc1) ] ] - Just bindDocs@(_:_) -> docAlt $ - case indentPolicy of - IndentPolicyLeft -> - --either - -- let - -- a = b - -- c = d - -- in foo - -- bar - -- baz - --or - -- let - -- a = b - -- c = d - -- in - -- fooooooooooooooooooo - [ docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ expDoc1 - ] - ] - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + Just bindDocs@(_:_) -> docAltFilter + --either + -- let + -- a = b + -- c = d + -- in foo + -- bar + -- baz + --or + -- let + -- a = b + -- c = d + -- in + -- fooooooooooooooooooo + [ ( indentPolicy == IndentPolicyLeft + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ expDoc1 ] ] - _ -> - [ docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 - ] + ) + , ( indentPolicy /= IndentPolicyLeft + , docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs ] - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 ] ] + ) + , ( True + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] + ) + ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo DoExpr (L _ stmts) _ -> do -- 2.30.2 From de0851f97537132559cd65d7d3347e4a8a5989cb Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sat, 25 Nov 2017 20:34:07 -0500 Subject: [PATCH 032/478] Use docAltFilter for consistency. --- .../Brittany/Internal/Layouters/Stmt.hs | 24 ++++++++++--------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 6f95585..e1cf215 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -64,17 +64,19 @@ layoutStmt lstmt@(L _ stmt) = do (docLit $ Text.pack "let") (docSetBaseAndIndent $ return bindDoc) ] - Just bindDocs -> - let letSeq = docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs - ] - letRegular = docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - in case indentPolicy of - IndentPolicyLeft -> docAlt [letRegular] - _ -> docAlt [letSeq, letRegular] + Just bindDocs -> docAltFilter + [ ( indentPolicy /= IndentPolicyLeft + , docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + ) + , ( True + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + ) + ] RecStmt stmts _ _ _ _ _ _ _ _ _ -> do docSeq [ docLit (Text.pack "rec") -- 2.30.2 From e9a2de7a85593c0c89fda522df4362efb1f06f13 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sat, 25 Nov 2017 20:50:17 -0500 Subject: [PATCH 033/478] Filter binders with docSetBaseAndIndent. --- src-literatetests/tests-context-free.blt | 27 +++++---- .../Brittany/Internal/Layouters/Expr.hs | 56 ++++++++++--------- .../Brittany/Internal/Layouters/Stmt.hs | 28 ++++++---- 3 files changed, 63 insertions(+), 48 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index f5ab85c..34f314b 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -532,7 +532,8 @@ func = do #test let func = do - let x = 13 + let + x = 13 stmt x @@ -1021,7 +1022,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do ] | not hasComments , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards + , let + guardPart = singleLineGuardsDoc guards , wherePart <- case mWhereDocs of Nothing -> return @[] $ docEmpty Just [w] -> return @[] $ docSeq @@ -1042,7 +1044,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do ] ++ wherePartMultiLine | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards + , let + guardPart = singleLineGuardsDoc guards , Data.Maybe.isJust mWhereDocs ] ++ -- two-line solution + where in next line(s) @@ -1054,18 +1057,20 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do ] ++ wherePartMultiLine | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards + , 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 + 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 @@ -1109,7 +1114,7 @@ foo = ## from the input; i cannot really express this yet with the current ## test-suite. ## #test ayaz -## +## ## myManageHook = ## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] ## <+> composeAll diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index c3f4429..38f3808 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -539,33 +539,39 @@ layoutExpr lexpr@(L _ expr) = do -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. docSetIndentLevel $ case mBindDocs of - Just [bindDoc] -> docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline $ return bindDoc - , appSep $ docLit $ Text.pack "in" - , docForceSingleline $ expDoc1 - ] - , docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ return bindDoc - ] + Just [bindDoc] -> docAltFilter + [ ( indentPolicy /= IndentPolicyLeft , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 + [ appSep $ docLit $ Text.pack "let" + , appSep $ docForceSingleline $ return bindDoc + , appSep $ docLit $ Text.pack "in" + , docForceSingleline $ expDoc1 ] - ] - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (appSep $ docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - , docAddBaseY BrIndentRegular - $ docPar - (appSep $ docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) - ] + ) + , ( indentPolicy /= IndentPolicyLeft + , docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ return bindDoc + ] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 + ] + ] + ) + , ( True + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (appSep $ docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) + , docAddBaseY BrIndentRegular + $ docPar + (appSep $ docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] + ) ] Just bindDocs@(_:_) -> docAltFilter --either diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index e1cf215..5bd33d3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -50,19 +50,23 @@ layoutStmt lstmt@(L _ stmt) = do ] LetStmt binds -> layoutLocalBinds binds >>= \case Nothing -> docLit $ Text.pack "let" -- i just tested - -- it, and it is - -- indeed allowed. - -- heh. + -- it, and it is + -- indeed allowed. + -- heh. Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAlt - [ docCols - ColDoLet - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ return bindDoc - ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) + Just [bindDoc] -> docAltFilter + [ ( indentPolicy /= IndentPolicyLeft + , docCols + ColDoLet + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ return bindDoc + ] + ) + , ( True + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) + ) ] Just bindDocs -> docAltFilter [ ( indentPolicy /= IndentPolicyLeft -- 2.30.2 From f6859d184fd3479b8fdd74f74334405295dcfade Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Mon, 27 Nov 2017 13:05:04 -0500 Subject: [PATCH 034/478] Fix tests after rebase. --- src-literatetests/10-tests.blt | 2 +- src-literatetests/tests-context-free.blt | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 03b1c6b..962a2cb 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -227,7 +227,7 @@ func {-# LANGUAGE ScopedTypeVariables #-} func :: forall m - . ColMap2 + . ColMap2 -> ColInfo -> ColInfo -> ColInfo diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 34f314b..5048175 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -663,9 +663,7 @@ func = do } #test record construction 1 -func = Foo - { _lstate_indent = _lstate_indent state - } +func = Foo {_lstate_indent = _lstate_indent state} #test record construction 2 func = Foo -- 2.30.2 From 9e8571b848d8e3f2f68f98a7b73621fe7a7fea52 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 27 Nov 2017 23:00:26 +0100 Subject: [PATCH 035/478] Remove an unnecessary node in BriDoc construction; Add TODO --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 38f3808..d108ed1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -419,6 +419,8 @@ layoutExpr lexpr@(L _ expr) = do case indentPolicy of IndentPolicyLeft -> BrIndentRegular _ -> BrIndentSpecial 3 + -- TODO: some of the alternatives (especially last and last-but-one) + -- overlap. docAltFilter [ -- if _ then _ else _ (,) (not hasComments) @@ -447,8 +449,7 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - ( docAddBaseY maySpecialIndent - $ docSeq + ( docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc ]) -- 2.30.2 From 466ff237ff4d9417aecc77ba05acdd784dd8674b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 27 Nov 2017 23:05:47 +0100 Subject: [PATCH 036/478] Add some comments/examples in layoutStmt --- .../Brittany/Internal/Layouters/Stmt.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 5bd33d3..3cc40f1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -55,27 +55,37 @@ layoutStmt lstmt@(L _ stmt) = do -- heh. Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [bindDoc] -> docAltFilter - [ ( indentPolicy /= IndentPolicyLeft + [ -- let bind = expr + ( indentPolicy /= IndentPolicyLeft , docCols ColDoLet [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ return bindDoc ] ) - , ( True + , -- let + -- bind = expr + ( True , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ return bindDoc) ) ] Just bindDocs -> docAltFilter - [ ( indentPolicy /= IndentPolicyLeft + [ -- let aaa = expra + -- bbb = exprb + -- ccc = exprc + ( indentPolicy /= IndentPolicyLeft , docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines $ return <$> bindDocs ] ) - , ( True + , -- let + -- aaa = expra + -- bbb = exprb + -- ccc = exprc + ( True , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) -- 2.30.2 From d9155e240d72135294e2a21079d1d17214a08333 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 27 Nov 2017 23:09:14 +0100 Subject: [PATCH 037/478] RecursiveDo: Add second layout, Respect IndentPolicyLeft --- .../Brittany/Internal/Layouters/Stmt.hs | 27 ++++++++++++++----- 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 3cc40f1..c9494e3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -91,12 +91,27 @@ layoutStmt lstmt@(L _ stmt) = do (docSetBaseAndIndent $ docLines $ return <$> bindDocs) ) ] - RecStmt stmts _ _ _ _ _ _ _ _ _ -> do - docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] + RecStmt stmts _ _ _ _ _ _ _ _ _ -> docAltFilter + [ -- rec stmt1 + -- stmt2 + -- stmt3 + ( indentPolicy /= IndentPolicyLeft + , docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts + ] + ) + , -- rec + -- stmt1 + -- stmt2 + -- stmt3 + ( True + , docAddBaseY BrIndentRegular $ docPar + (docLit (Text.pack "rec")) + (docLines $ layoutStmt <$> stmts) + ) + ] BodyStmt expr _ _ _ -> do expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc -- 2.30.2 From 6a97379b330078463cfd89353cf76787ce66a678 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 28 Nov 2017 17:56:28 +0100 Subject: [PATCH 038/478] Add whitespace around operator in section, Fixes #67 --- src-literatetests/10-tests.blt | 9 ++++----- src-literatetests/15-regressions.blt | 12 ++++++++---- .../Haskell/Brittany/Internal/Layouters/Expr.hs | 4 ++-- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 03b1c6b..e04887c 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -461,17 +461,16 @@ func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas ### #test left -func = (1+) +func = (1 +) #test right -func = (+1) +func = (+ 1) #test left inf -## TODO: this could be improved.. -func = (1`abc`) +func = (1 `abc`) #test right inf -func = (`abc`1) +func = (`abc` 1) ### #group tuples diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index bea97cc..319713b 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -324,17 +324,17 @@ func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo parserPrim = [ r | r <- - [ SGPPrimFloat $ bool id (0-) minus $ readGnok "parserPrim" - (d1 ++ d2 ++ d3 ++ d4) + [ 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 + <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral (readGnok "parserPrim" d1 :: Integer) | _ <- string "f" ] - <|> [ SGPPrimInt $ bool id (0-) minus $ fromIntegral + <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral (readGnok "parserPrim" d1 :: Integer) | _ <- string "i" ] @@ -486,3 +486,7 @@ func -> Proxy (str :: [*]) -> m (Tagged str String) +#test issue 67 +fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b +fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) + diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 90fd435..0e36a21 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -321,11 +321,11 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of SectionL left op -> do -- TODO: add to testsuite leftDoc <- docSharedWrapper layoutExpr left opDoc <- docSharedWrapper layoutExpr op - docSeq [leftDoc, opDoc] + docSeq [leftDoc, docSeparator, opDoc] SectionR op right -> do -- TODO: add to testsuite opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right - docSeq [opDoc, rightDoc] + docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple args boxity | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do argDocs <- docSharedWrapper layoutExpr `mapM` argExprs -- 2.30.2 From 8a401d291efb44550e4b0a641aa311dab04d3891 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 28 Nov 2017 18:23:05 +0100 Subject: [PATCH 039/478] Workaround for #68: trim exactprinted text for unknown nodes --- src-literatetests/15-regressions.blt | 3 +++ .../Brittany/Internal/LayouterBasics.hs | 21 +++++++++++-------- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 319713b..0876dc3 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -490,3 +490,6 @@ func fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) + +#test parallellistcomp-workaround +cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index a0a3c7b..52c9e08 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -82,6 +82,8 @@ import ApiAnnotation ( AnnKeywordId(..) ) import Data.Data import Data.Generics.Schemes +import qualified Data.Char as Char + import DataTreePrint import Data.HList.HList @@ -154,20 +156,21 @@ briDocByExactInlineOnly infoStr ast = do let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let exactPrintNode = allocateNode $ BDFExternal + let exactPrintNode t = allocateNode $ BDFExternal (ExactPrint.Types.mkAnnKey ast) (foldedAnnKeys ast) False - exactPrinted - let - errorAction = do - mTell $ [ErrorUnknownNode infoStr ast] - docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + t + let errorAction = do + mTell $ [ErrorUnknownNode infoStr ast] + docLit + $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of (ExactPrintFallbackModeNever, _ ) -> errorAction - (_ , [_]) -> exactPrintNode - (ExactPrintFallbackModeRisky, _ ) -> exactPrintNode - _ -> errorAction + (_ , [t]) -> exactPrintNode + (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) + (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted + _ -> errorAction rdrNameToText :: RdrName -> Text -- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr -- 2.30.2 From 882a3b1a7a7851b36fb147580ad36eda2d28abc6 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 27 Nov 2017 23:27:33 +0100 Subject: [PATCH 040/478] Allow single-line after let with IndentPolicyLeft --- src-literatetests/tests-context-free.blt | 12 +++---- .../Brittany/Internal/Layouters/Expr.hs | 2 +- .../Brittany/Internal/Layouters/Stmt.hs | 31 +++++++++---------- 3 files changed, 20 insertions(+), 25 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 5048175..5f5765a 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -532,8 +532,7 @@ func = do #test let func = do - let - x = 13 + let x = 13 stmt x @@ -1020,8 +1019,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do ] | not hasComments , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let - guardPart = singleLineGuardsDoc guards + , let guardPart = singleLineGuardsDoc guards , wherePart <- case mWhereDocs of Nothing -> return @[] $ docEmpty Just [w] -> return @[] $ docSeq @@ -1042,8 +1040,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do ] ++ wherePartMultiLine | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let - guardPart = singleLineGuardsDoc guards + , let guardPart = singleLineGuardsDoc guards , Data.Maybe.isJust mWhereDocs ] ++ -- two-line solution + where in next line(s) @@ -1055,8 +1052,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do ] ++ wherePartMultiLine | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let - guardPart = singleLineGuardsDoc guards + , let guardPart = singleLineGuardsDoc guards ] #test comment-testcase-17 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index d108ed1..4b96241 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -541,7 +541,7 @@ layoutExpr lexpr@(L _ expr) = do -- comments before the first let item are moved horizontally with it. docSetIndentLevel $ case mBindDocs of Just [bindDoc] -> docAltFilter - [ ( indentPolicy /= IndentPolicyLeft + [ ( True , docSeq [ appSep $ docLit $ Text.pack "let" , appSep $ docForceSingleline $ return bindDoc diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index c9494e3..b8814cd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -54,22 +54,22 @@ layoutStmt lstmt@(L _ stmt) = do -- indeed allowed. -- heh. Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAltFilter + Just [bindDoc] -> docAlt [ -- let bind = expr - ( indentPolicy /= IndentPolicyLeft - , docCols - ColDoLet - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ return bindDoc - ] - ) + docCols + ColDoLet + [ appSep $ docLit $ Text.pack "let" + , ( if indentPolicy == IndentPolicyLeft + then docForceSingleline + else docSetBaseAndIndent + ) + $ return bindDoc + ] , -- let -- bind = expr - ( True - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - ) + docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) ] Just bindDocs -> docAltFilter [ -- let aaa = expra @@ -107,9 +107,8 @@ layoutStmt lstmt@(L _ stmt) = do -- stmt2 -- stmt3 ( True - , docAddBaseY BrIndentRegular $ docPar - (docLit (Text.pack "rec")) - (docLines $ layoutStmt <$> stmts) + , docAddBaseY BrIndentRegular + $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) ) ] BodyStmt expr _ _ _ -> do -- 2.30.2 From 072b1cf09136e75417f10a0b52b2e3a0d8de7f6f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 1 Dec 2017 00:12:09 +0100 Subject: [PATCH 041/478] Make macOS the first travis build job (it is slowest) --- .travis.yml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 5922f50..58a0f33 100644 --- a/.travis.yml +++ b/.travis.yml @@ -61,6 +61,13 @@ matrix: # compiler: ": #GHC 7.10.3" # addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + ##### OSX test via stack ##### + + # Build on macOS in addition to Linux + - env: BUILD=stack ARGS="" + compiler: ": #stack default osx" + os: osx + ##### CABAL ##### - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 @@ -117,11 +124,6 @@ matrix: compiler: ": #stack nightly" addons: {apt: {packages: [libgmp-dev]}} - # Build on macOS in addition to Linux - - env: BUILD=stack ARGS="" - compiler: ": #stack default osx" - os: osx - # Travis includes an macOS which is incompatible with GHC 7.8.4 #- env: BUILD=stack ARGS="--resolver lts-2" # compiler: ": #stack 7.8.4 osx" -- 2.30.2 From 39c48b33f1a45fe2265719ff735ae5d22d3b63be Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Dec 2017 19:57:16 +0100 Subject: [PATCH 042/478] Fix error in Annotation filtering (fixes #70) --- src-literatetests/15-regressions.blt | 4 ++++ src/Language/Haskell/Brittany/Internal.hs | 8 ++++---- .../Haskell/Brittany/Internal/ExactPrintUtils.hs | 15 +++++++++++---- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 029caa1..c2290ba 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -509,3 +509,7 @@ fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) #test parallellistcomp-workaround cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] + +#test issue 70 +{-# LANGUAGE TemplateHaskell #-} +deriveFromJSON (unPrefix "assignPost") ''AssignmentPost diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 64c139a..e6256ec 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -320,8 +320,8 @@ withTransformedAnns ast m = do ppDecl :: LHsDecl RdrName -> PPMLocal () ppDecl d@(L loc decl) = case decl of - SigD sig -> -- trace (_sigHead sig) $ - withTransformedAnns d $ do + SigD sig -> -- trace (_sigHead sig) $ + withTransformedAnns d $ do -- runLayouter $ Old.layoutSig (L loc sig) briDoc <- briDocMToPPM $ layoutSig (L loc sig) layoutBriDoc briDoc @@ -332,9 +332,9 @@ ppDecl d@(L loc decl) = case decl of eitherNode <- layoutBind (L loc bind) case eitherNode of Left ns -> docLines $ return <$> ns - Right n -> return n + Right n -> return n layoutBriDoc briDoc - _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc + _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc _sigHead :: Sig RdrName -> String _sigHead = \case diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 74ed50d..081032d 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -217,11 +217,18 @@ extractToplevelAnns extractToplevelAnns lmod anns = output where (L _ (HsModule _ _ _ ldecls _ _)) = lmod - declMap :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap = Map.unions $ ldecls <&> \ldecl -> + declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap1 = 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 + declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap2 = + Map.fromList + $ [ (captured, declMap1 Map.! k) + | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns + ] + declMap = declMap1 `Map.union` declMap2 + modKey = ExactPrint.mkAnnKey lmod + output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) -- 2.30.2 From eba7fc0d37eccb0edfb6130602974dcad3a0f58d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Dec 2017 19:59:06 +0100 Subject: [PATCH 043/478] Add ChangeLog for 0.9.0.0 --- ChangeLog.md | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 236a7ad..d496b0c 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,31 @@ # Revision history for brittany +## 0.9.0.0 -- December 2017 + +* Change default global config path (use XDG spec) + Existing config should still be respected, so this should not break + compatibility +* ! Slight rework of the commandline interface: + - Support multiple inputs and outputs + - Support inplace-transformation for multiple files via + `--write-mode=inplace` +* Implement `IndentPolicyLeft` - the indentation mode that never adds more + than the base indentation for nested parts (no hanging indentation) + + (thanks to Evan Borden) +* Fix bug that manifested in bad output for (top-level) template haskell splices +* Extension support: + - RecordWildCards + - RecursiveDo (was only partially supported previously) +* Layouting Bugfixes: + - Properly reproduce parentheses around kind signatures + - Fix issue around promoted lists + (example good: `'[ 'True]` bad: `'['True]`) + - Trim text from exactprint used as workaround for unknown nodes + (unsupported extension workaround) +* Layouting changes + - Insert spaces around operator in sections + ## 0.8.0.3 -- September 2017 * Support for ghc-8.2.1 -- 2.30.2 From 16d511619318f22edbbb80d41fcc54a5543c2a00 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Dec 2017 21:11:39 +0100 Subject: [PATCH 044/478] Bump to 0.9.0.0 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index bf2ba63..84c4225 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.8.0.3 +version: 0.9.0.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 4ded834a97c99979885b06ecd12ed62f61896884 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Dec 2017 21:14:35 +0100 Subject: [PATCH 045/478] Clean-up cabal file: Remove development flag --- brittany.cabal | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 84c4225..bfba1dc 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -32,11 +32,6 @@ source-repository head { location: https://github.com/lspitzner/brittany.git } -flag brittany-dev - description: dev options - default: False - manual: True - flag brittany-dev-lib description: set buildable false for anything but lib default: False @@ -83,9 +78,6 @@ library { -fno-warn-unused-imports -fno-warn-redundant-constraints } - if flag(brittany-dev) { - ghc-options: -O0 -Werror -fobject-code - } build-depends: { base >=4.9 && <4.11 , ghc >=8.0.1 && <8.3 @@ -206,14 +198,6 @@ executable brittany -rtsopts -with-rtsopts "-M2G" } - if flag(brittany-dev) { - ghc-options: - -O0 - -Werror - -fobject-code - -fprof-auto - -fprof-cafs - } test-suite unittests if flag(brittany-dev-lib) { @@ -282,9 +266,6 @@ test-suite unittests -rtsopts -with-rtsopts "-M2G" } - if flag(brittany-dev) { - ghc-options: -O0 -Werror -fobject-code - } test-suite littests if flag(brittany-dev-lib) { @@ -354,9 +335,6 @@ test-suite littests -rtsopts -with-rtsopts "-M2G" } - if flag(brittany-dev) { - ghc-options: -O0 -Werror -fobject-code - } test-suite libinterfacetests if flag(brittany-dev-lib) { -- 2.30.2 From 3130fecf077d71b02b8b4d51de760b928dded910 Mon Sep 17 00:00:00 2001 From: Louis Pilfold Date: Sat, 9 Dec 2017 15:09:22 +0000 Subject: [PATCH 046/478] Add missing code blocks to layout docs --- doc/showcases/Layout_Types.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/doc/showcases/Layout_Types.md b/doc/showcases/Layout_Types.md index d34ca14..abf05e8 100644 --- a/doc/showcases/Layout_Types.md +++ b/doc/showcases/Layout_Types.md @@ -44,6 +44,7 @@ linewise -> RH.AppHost t () ~~~~ +~~~~.hs linewise :: forall n t. (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t)) @@ -54,8 +55,9 @@ linewise :: , R.Behavior t String -- tab-completion value , R.Dynamic t (Widget n))) -> RH.AppHost t () +~~~~ - +~~~~.hs processDefault :: ( ExactPrint.Annotate.Annotate ast , MonadMultiWriter Text.Builder.Builder m @@ -63,3 +65,4 @@ processDefault :: ) => Located ast -> m () +~~~~ -- 2.30.2 From 07b928b00c3c614fc14995442ef16ae382874824 Mon Sep 17 00:00:00 2001 From: Damien Flament Date: Mon, 11 Dec 2017 13:10:57 +0100 Subject: [PATCH 047/478] Added ArchLinux installation instructions --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 5d232a2..abddb2f 100644 --- a/README.md +++ b/README.md @@ -83,6 +83,10 @@ require fixing: stack install ~~~~ +- via `aura` on ArchLinux + ~~~~.sh + aura -A brittany + ~~~~ # Usage -- 2.30.2 From b79a0908c8163e933c7253c11e71db9f7ceaaa82 Mon Sep 17 00:00:00 2001 From: Damien Flament Date: Mon, 11 Dec 2017 16:44:39 +0100 Subject: [PATCH 048/478] Added link to the AUR package --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index abddb2f..bda4f1b 100644 --- a/README.md +++ b/README.md @@ -83,7 +83,8 @@ require fixing: stack install ~~~~ -- via `aura` on ArchLinux +- on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/) + using `aura`: ~~~~.sh aura -A brittany ~~~~ -- 2.30.2 From 442f32aef9eb710b2f15577100c30f5aec8bb9b8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 11 Dec 2017 17:10:27 +0100 Subject: [PATCH 049/478] Update README.md: stack with recent resolver --- README.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index bda4f1b..99997f4 100644 --- a/README.md +++ b/README.md @@ -75,14 +75,15 @@ require fixing: cp `./find dist-newstyle/build/ -type f -name brittany` $HOME/.cabal/bin/ ~~~~ -- via `stack` +- via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) ~~~~.sh - git clone https://github.com/lspitzner/brittany.git - cd brittany - stack install + stack install brittany # --resolver=nightly-2017-11-15 ~~~~ + (alternatively, should nightlies be unreliable, or you want to use ghc-8.0 or something, then + cloning the repo and doing `stack install` will use an lts resolver.) + - on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`: ~~~~.sh -- 2.30.2 From 95e4346742b9a0fbe498ece9367f28a51561548d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 11 Dec 2017 16:51:10 +0100 Subject: [PATCH 050/478] one fixup addition to the 0.9.0.0 changelog --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index d496b0c..05a7ea2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,7 @@ * Change default global config path (use XDG spec) Existing config should still be respected, so this should not break compatibility +* Support per-project config * ! Slight rework of the commandline interface: - Support multiple inputs and outputs - Support inplace-transformation for multiple files via -- 2.30.2 From 0036dbf41086030083ba9aec3f0165c06fe62f30 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 11 Dec 2017 17:13:33 +0100 Subject: [PATCH 051/478] Add some documentation for `layoutPat` --- .../Brittany/Internal/Layouters/Pattern.hs | 30 +++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 3f66932..ebdd91d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -24,12 +24,26 @@ import Language.Haskell.Brittany.Internal.Layouters.Type +-- | layouts patterns (inside function bindings, case alternatives, let +-- bindings or do notation). E.g. for input +-- > case computation of +-- > (warnings, Success a b) -> .. +-- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by +-- 'layoutPat'. Similarly for +-- > func abc True 0 = [] +-- ^^^^^^^^^^ this part +-- We will use `case .. of` as the imagined prefix to the examples used in +-- the different cases below. layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + -- _ -> expr VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n + -- abc -> expr LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit + -- 0 -> expr ParPat inner -> do + -- (nestedpat) -> expr left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" innerDocs <- colsWrapPat =<< layoutPat inner @@ -49,6 +63,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] -- return $ (x1' Seq.<| middle) Seq.|> xN' ConPatIn lname (PrefixCon args) -> do + -- Abc a b c -> expr let nameDoc = lrdrNameToText lname argDocs <- layoutPat `mapM` args if null argDocs @@ -61,15 +76,19 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of $ fmap colsWrapPat argDocs return $ x1 Seq.<| xR ConPatIn lname (InfixCon left right) -> do + -- a :< b -> expr let nameDoc = lrdrNameToText lname leftDoc <- colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right middle <- docLit nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do + -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + -- Abc { a = locA, b = locB, c = locC } -> expr1 + -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do fExpDoc <- if pun @@ -91,12 +110,14 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docLit $ Text.pack "}" ] ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do + -- Abc { .. } -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docSeq [ appSep $ docLit t , docLit $ Text.pack "{..}" ] ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do + -- Abc { a = locA, .. } let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do fExpDoc <- if pun @@ -117,16 +138,20 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docLit $ Text.pack "..}" ] TuplePat args boxity _ -> do + -- (nestedpat1, nestedpat2, nestedpat3) -> expr + -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of Boxed -> wrapPatListy args "(" ")" Unboxed -> wrapPatListy args "(#" "#)" AsPat asName asPat -> do + -- bind@nestedpat -> expr 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 + -- i :: Int -> expr patDocs <- layoutPat pat1 tyDoc <- docSharedWrapper layoutType ty1 case Seq.viewr patDocs of @@ -146,12 +171,17 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of ] return $ xR Seq.|> xN' ListPat elems _ _ -> + -- [] -> expr1 + -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 wrapPatListy elems "[" "]" BangPat pat1 -> do + -- !nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "!") LazyPat pat1 -> do + -- ~nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "~") NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do + -- -13 -> expr litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit negDoc <- docLit $ Text.pack "-" pure $ case mNegative of -- 2.30.2 From b731cd15e7e69fb3d793af906d9c05ca76c3879a Mon Sep 17 00:00:00 2001 From: Matthew Piziak Date: Thu, 14 Dec 2017 16:17:39 -0500 Subject: [PATCH 052/478] capture starting layout --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 0ed8a31..2eb1863 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -341,9 +341,9 @@ layoutExpr lexpr@(L _ expr) = do opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] - ExplicitTuple args boxity - | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do - argDocs <- docSharedWrapper layoutExpr `mapM` argExprs + ExplicitTuple args boxity -> do + let argExprs = fmap (\case (L _ (Present e)) -> Just e; (L _ (Missing PlaceHolder)) -> Nothing) args + argDocs <- docSharedWrapper (maybe docEmpty layoutExpr) `mapM` argExprs hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") @@ -385,8 +385,6 @@ layoutExpr lexpr@(L _ expr) = do end = closeLit in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] - ExplicitTuple{} -> - unknownNodeError "ExplicitTuple|.." lexpr HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" -- 2.30.2 From 9704fc34908bba3a6e6c4e1ccd04ca0382b19e92 Mon Sep 17 00:00:00 2001 From: Matthew Piziak Date: Thu, 14 Dec 2017 18:15:07 -0500 Subject: [PATCH 053/478] add tuple section tests --- src-literatetests/10-tests.blt | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index c6d4203..a3d8591 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -476,9 +476,23 @@ func = (`abc` 1) #group tuples ### -#test 1 +#test pair func = (abc, def) +#test pair section left +func = (abc, ) + +#test pair section right +func = (, abc) + +#test quintuple section long +myTupleSection = + ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement + , + , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement + , + ) + #test 2 #pending func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd -- 2.30.2 From f7e5287f1d0b587e761ea344fd2337ac3f283e20 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 15 Dec 2017 15:13:11 +0100 Subject: [PATCH 054/478] Update README.md (0.9.0.0 changes, widget) --- README.md | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 99997f4..3196b27 100644 --- a/README.md +++ b/README.md @@ -43,13 +43,19 @@ require fixing: accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.~~ (fixed in `0.8.0.3`) +## Try without Installing + +You can [paste haskell code over here](https://hexagoxel.de/brittany/) +to test how it gets formatted by brittany. (Rg. privacy: the server does +log the size of the input, but _not_ the full requests.) + # Other usage notes - Supports GHC versions `8.0.*` and `8.2.*`. - as of November'17, `brittany` is available on stackage nightly. - config (file) documentation is lacking. - some config values can not be configured via commandline yet. -- uses/creates user config file in `~/.brittany/config.yaml`; +- uses/creates user config file in `~/.config/brittany/config.yaml`; also reads `brittany.yaml` in current dir if present. # Installation @@ -92,12 +98,19 @@ require fixing: # Usage -- Currently one mode of operation: Transform a single module. By default read - from `stdin` and written to `stdout`, but commandline arguments allow to - read/write from/to files. +- Default mode of operation: Transform a single module, from `stdin` to `stdout`. + Can pass one or multiple files as input, and there is a flag to override them + in place instead of using `stdout` (since 0.9.0.0). So: + + ~~~~ .sh + brittany # stdin -> stdout + brittany mysource.hs # ./mysource.hs -> stdout + brittany --write-mode=inplace *.hs # apply formatting to all ./*.hs inplace + ~~~~ + - For stdin/stdout usage it makes sense to enable certain syntactic extensions by default, i.e. to add something like this to your - `~/.brittany/config.yaml` (execute `brittany` once to create default): + `~/.config/brittany/config.yaml` (execute `brittany` once to create default): ~~~~ conf_forward: -- 2.30.2 From a24f092aac34accb41cce889e2a0f3b655637faa Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 15 Dec 2017 20:55:31 +0100 Subject: [PATCH 055/478] Update doc-svg-gen.cabal to prevent new-configure annoyance --- doc-svg-gen/doc-svg-gen.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc-svg-gen/doc-svg-gen.cabal b/doc-svg-gen/doc-svg-gen.cabal index cb093c9..424b841 100644 --- a/doc-svg-gen/doc-svg-gen.cabal +++ b/doc-svg-gen/doc-svg-gen.cabal @@ -5,12 +5,12 @@ extra-source-files: ChangeLog.md cabal-version: >=1.10 executable doc-svg-gen - buildable: True + buildable: False main-is: Main.hs -- other-modules: -- other-extensions: build-depends: - { base >=4.9 && <4.10 + { base >=4.9 && <4.11 , text , graphviz >=2999.19.0.0 } -- 2.30.2 From ee9abff9e8e56e96ba0bb78a84c1f6a7491b60ea Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sat, 16 Dec 2017 14:00:49 +0100 Subject: [PATCH 056/478] Add import and module support --- brittany.cabal | 3 + src-literatetests/10-tests.blt | 162 ++++++++++++++++++ src/Language/Haskell/Brittany/Internal.hs | 74 +++++--- .../Haskell/Brittany/Internal/Layouters/IE.hs | 70 ++++++++ .../Brittany/Internal/Layouters/Import.hs | 62 +++++++ .../Brittany/Internal/Layouters/Module.hs | 73 ++++++++ 6 files changed, 419 insertions(+), 25 deletions(-) create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/IE.hs create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/Import.hs create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/Module.hs diff --git a/brittany.cabal b/brittany.cabal index bfba1dc..173345e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -67,6 +67,9 @@ library { Language.Haskell.Brittany.Internal.Layouters.Expr Language.Haskell.Brittany.Internal.Layouters.Stmt Language.Haskell.Brittany.Internal.Layouters.Pattern + Language.Haskell.Brittany.Internal.Layouters.IE + Language.Haskell.Brittany.Internal.Layouters.Import + Language.Haskell.Brittany.Internal.Layouters.Module Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index c6d4203..f1ea640 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -544,3 +544,165 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] +### +#group module +### + +#test simple +module Main where + +#test no-exports +module Main () where + +#test one-export +module Main (main) where + +#test several-exports +module Main (main, test1, test2) where + +#test many-exports +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) +where + +#test exports-with-comments +module Main + ( main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + ) +where + +#test simple-export-with-things +module Main (Test(..)) where + +#test simple-export-with-module-contents +module Main (module Main) where + +#test export-with-things +module Main (Test(Test, a, b)) where + +#test export-with-empty-thing +module Main (Test()) where + +#test empty-with-comment +-- Intentionally left empty + +### +#group import +### + +#test simple-import +import Data.List + +#test simple-import-alias +import Data.List as L + +#test simple-qualified-import +import qualified Data.List + +#test simple-qualified-import-alias +import qualified Data.List as L + +#test simple-safe +import safe Data.List + +#test simple-source +import {-# SOURCE #-} Data.List + +#test simple-safe-qualified +import safe qualified Data.List + +#test simple-safe-qualified-source +import {-# SOURCE #-} safe qualified Data.List + +#test simple-qualified-package +import qualified "base" Data.List + +#test instances-only +import qualified Data.List () + +#test one-element +import Data.List (nub) + +#test several-elements +import Data.List (nub, foldl', indexElem) + +#test with-things +import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) + +#test hiding +import Test hiding () +import Test as T hiding () + +#test horizontal-layout +import Data.List (nub) +import qualified Data.List as L (foldl') + +import Test (test) +import Main hiding + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) + +#test import-with-comments +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) + +#test preamble full-preamble +{-# LANGUAGE BangPatterns #-} + +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ) +where + +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e6256ec..73a6799 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -33,6 +33,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils @@ -155,7 +156,7 @@ pPrintModule conf anns parsedModule = in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do - -- + -- -- debugStrings `forM_` \s -> -- trace s $ return () @@ -243,30 +244,8 @@ parsePrintModuleTests conf filename input = do -- else return $ TextL.toStrict $ Text.Builder.toLazyText out ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () -ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do - let emptyModule = L loc m { hsmodDecls = [] } - (anns', post) <- do - anns <- mAsk - -- evil partiality. but rather unlikely. - return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of - Nothing -> (anns, []) - Just mAnn -> - let modAnnsDp = ExactPrint.Types.annsDP mAnn - isWhere (ExactPrint.Types.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.Types.G AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post) = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.Types.annsDP = pre } - anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns - in (anns', post) - MultiRWSS.withMultiReader anns' $ processDefault emptyModule +ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do + post <- ppPreamble lmod decls `forM_` \decl -> do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap @@ -336,6 +315,51 @@ ppDecl d@(L loc decl) = case decl of layoutBriDoc briDoc _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc +-- Prints the information associated with the module annotation +-- This includes the imports +ppPreamble :: GenLocated SrcSpan (HsModule RdrName) + -> PPM [(ExactPrint.Types.KeywordId, ExactPrint.Types.DeltaPos)] +ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do + filteredAnns <- mAsk <&> \annMap -> + Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey lmod) annMap + -- Since ghc-exactprint adds annotations following (implicit) + -- modules to both HsModule and the elements in the module + -- this can cause duplication of comments. So strip + -- attached annotations that come after the module's where + -- from the module node + let (filteredAnns', post) = + case (ExactPrint.Types.mkAnnKey lmod) `Map.lookup` filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let modAnnsDp = ExactPrint.Types.annsDP mAnn + isWhere (ExactPrint.Types.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.Types.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + mAnn' = mAnn { ExactPrint.Types.annsDP = pre } + filteredAnns'' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' filteredAnns + in (filteredAnns'', post') + in do + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' + + config <- mAsk + + MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil + withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + return post + _sigHead :: Sig RdrName -> String _sigHead = \case TypeSig names _ -> diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs new file mode 100644 index 0000000..8f09d91 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -0,0 +1,70 @@ +module Language.Haskell.Brittany.Internal.Layouters.IE + ( layoutIE + , layoutIEList + ) +where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils + + +layoutIE :: ToBriDoc IE +layoutIE lie@(L _ _ie) = + docWrapNode lie + $ let + ien = docLit $ rdrNameToText $ ieName _ie + in + case _ie of + IEVar _ -> ien + IEThingAbs _ -> ien + IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ (IEWildcard _) _ _ -> + docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ _ ns fs -> + let + prepareFL = + docLit . Text.pack . FastString.unpackFS . flLabel . unLoc + in + docSeq + $ [ien, docLit $ Text.pack "("] + ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText) ns) + ++ intersperse docCommaSep (map (prepareFL) fs) + ) + ++ [docLit $ Text.pack ")"] + IEModuleContents n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + +layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutIEList lies = do + ies <- mapM (docSharedWrapper layoutIE) lies + case ies of + [] -> docLit $ Text.pack "()" + (x:xs) -> docAlt + [ docSeq + $ [docLit $ Text.pack "(", x] + ++ map (\x' -> docSeq [docCommaSep, x']) xs + ++ [docLit $ Text.pack ")"] + , docLines + ( docSeq [docLit $ Text.pack "(", docSeparator, x] + : map (\x' -> docSeq [docCommaSep, x']) xs + ++ [docLit $ Text.pack ")"] + ) + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs new file mode 100644 index 0000000..b4e3e0c --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -0,0 +1,62 @@ +module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils + +layoutImport :: ToBriDoc ImportDecl +layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of + ImportDecl _ (L _ modName) pkg src safe q False as llies -> + let + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . sl_st <$> pkg + asT = Text.pack . moduleNameString <$> as + sig = ColBindingLine (Just (Text.pack "import")) + importQualifiers = docSeq + [ appSep $ docLit $ Text.pack "import" + , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty + , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty + , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty + , fromMaybe docEmpty (appSep . docLit <$> pkgNameT) + ] + makeAs asT' = + appSep $ docSeq [docLit (Text.pack "as"), docSeparator, docLit asT'] + importIds = + docSeq $ [appSep $ docLit modNameT, fromMaybe docEmpty (makeAs <$> asT)] + in + do + (hiding, ies) <- case llies of + Just (h, L _ lies) -> do + sies <- docSharedWrapper layoutIEList lies + return (h, sies) + Nothing -> return (False, docEmpty) + h <- docSharedWrapper + ( const + ( docSeq + [ docCols sig [importQualifiers, importIds] + , if hiding + then appSep $ docLit $ Text.pack "hiding" + else docEmpty + ] + ) + ) + () + docAlt + [ docSeq [h, docForceSingleline ies] + , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) + ] + _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs new file mode 100644 index 0000000..0093c46 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -0,0 +1,73 @@ +module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + +import Language.Haskell.Brittany.Internal.Utils + +layoutModule :: ToBriDoc HsModule +layoutModule lmod@(L _ mod') = do + case mod' of + -- Implicit module Main + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> + let + tn = Text.pack $ moduleNameString $ unLoc n + in + do + cs <- do + anns <- mAsk + case ExactPrint.Types.mkAnnKey lmod `Map.lookup` anns of + Just mAnn -> return $ extractAllComments mAnn + Nothing -> return [] + (hasComments, es) <- case les of + Nothing -> return (False, docEmpty) + Just llies@(L _ lies) -> do + hasComments <- hasAnyCommentsBelow llies + return (hasComments, docWrapNode llies $ layoutIEList lies) + docLines + ( [ -- A pseudo node that serves merely to force documentation + -- before the node + docWrapNode lmod $ docEmpty + | [] /= cs + ] + ++ [ docAlt + ( [ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , appSep $ docForceSingleline es + , docLit $ Text.pack "where" + ] + | not hasComments + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + ( docSeq + [ appSep $ docLit $ Text.pack "module" + , docLit tn + ] + ) + (docForceMultiline es) + , docLit $ Text.pack "where" + ] + ] + ) + ] + ++ map layoutImport imports + ) -- 2.30.2 From a72465ebef408468a06dfe9fa89f9d33edb8f92c Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sun, 17 Dec 2017 13:13:19 +0100 Subject: [PATCH 057/478] Add context-free tests --- src-literatetests/tests-context-free.blt | 163 ++++++++++++++++++++++- 1 file changed, 162 insertions(+), 1 deletion(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 7700adb..b8b0c4a 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -593,6 +593,168 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] +### +#group module +### + +#test simple +module Main where + +#test no-exports +module Main () where + +#test one-export +module Main (main) where + +#test several-exports +module Main (main, test1, test2) where + +#test many-exports +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) +where + +#test exports-with-comments +module Main + ( main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + ) +where + +#test simple-export-with-things +module Main (Test(..)) where + +#test simple-export-with-module-contents +module Main (module Main) where + +#test export-with-things +module Main (Test(Test, a, b)) where + +#test export-with-empty-thing +module Main (Test()) where + +#test empty-with-comment +-- Intentionally left empty + +### +#group import +### + +#test simple-import +import Data.List + +#test simple-import-alias +import Data.List as L + +#test simple-qualified-import +import qualified Data.List + +#test simple-qualified-import-alias +import qualified Data.List as L + +#test simple-safe +import safe Data.List + +#test simple-source +import {-# SOURCE #-} Data.List + +#test simple-safe-qualified +import safe qualified Data.List + +#test simple-safe-qualified-source +import {-# SOURCE #-} safe qualified Data.List + +#test simple-qualified-package +import qualified "base" Data.List + +#test instances-only +import qualified Data.List () + +#test one-element +import Data.List (nub) + +#test several-elements +import Data.List (nub, foldl', indexElem) + +#test with-things +import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) + +#test hiding +import Test hiding () +import Test as T hiding () + +#test horizontal-layout +import Data.List (nub) +import qualified Data.List as L (foldl') + +import Test (test) +import Main hiding + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) + +#test import-with-comments +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) + +#test preamble full-preamble +{-# LANGUAGE BangPatterns #-} + +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ) +where + +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) ############################################################################### ############################################################################### @@ -1128,4 +1290,3 @@ foo = ## ] ## where ## role = stringProperty "WM_WINDOW_ROLE" - -- 2.30.2 From e140cd01e07838699e8a74777de707ebda179bfd Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sun, 17 Dec 2017 14:00:16 +0100 Subject: [PATCH 058/478] Add directives for ghc > 8.2 --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 4 ++++ .../Brittany/Internal/Layouters/Import.hs | 19 +++++++++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 8f09d91..e6b83b7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -41,7 +41,11 @@ layoutIE lie@(L _ _ie) = in docSeq $ [ien, docLit $ Text.pack "("] +#if MIN_VERSION_ghc(8,2,0) + ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText . ieLWrappedName) ns) +#else ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText) ns) +#endif ++ intersperse docCommaSep (map (prepareFL) fs) ) ++ [docLit $ Text.pack ")"] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index b4e3e0c..6bfd63f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -23,8 +23,23 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False as llies -> let modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . sl_st <$> pkg - asT = Text.pack . moduleNameString <$> as +#if MIN_VERSION_ghc(8,2,0) + prepPkg rawN = + case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" +#else + prepPkg = id +#endif + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg +#if MIN_VERSION_ghc(8,2,0) + prepModName = unLoc +#else + prepModName = id +#endif + asT = Text.pack . moduleNameString . prepModName <$> as sig = ColBindingLine (Just (Text.pack "import")) importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" -- 2.30.2 From d8097f2862b7c2149fe9fda482bd60a6e624906c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 17 Dec 2017 15:45:08 +0100 Subject: [PATCH 059/478] Add mask_ to prevent "ghc panic" when using timeout on brittany --- src/Language/Haskell/Brittany/Internal.hs | 5 +++++ .../Haskell/Brittany/Internal/ExactPrintUtils.hs | 11 ++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e6256ec..b6987b5 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -61,6 +61,11 @@ import qualified GHC.LanguageExtensions.Type as GHC -- -- Note that this function ignores/resets all config values regarding -- debugging, i.e. it will never use `trace`/write to stderr. +-- +-- Note that the ghc parsing function used internally currently is wrapped in +-- `mask_`, so cannot be killed easily. If you don't control the input, you +-- may wish to put some proper upper bound on the input's size as a timeout +-- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configRaw inputText = runExceptT $ do let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 081032d..d0f481c 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -37,6 +37,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Data.Generics as SYB + +import Control.Exception -- import Data.Generics.Schemes @@ -85,7 +87,14 @@ parseModuleFromString -> String -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleFromString args fp dynCheck str = - ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do + -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will + -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we + -- cannot kill the parsing thread - not very nice. But i'll + -- optimistically assume that most of the time brittany uses noticable or + -- longer time, the majority of the time is not spend in parsing, but in + -- bridoc transformation stuff. + -- (reminder to update note on `parsePrintModule` if this changes.) + mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) -- 2.30.2 From 204f0aff0857968a24d0f0e2f968c3bd91a51e26 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 17 Dec 2017 20:47:52 +0100 Subject: [PATCH 060/478] import+module: Refactor and Simplify slightly --- src-literatetests/10-tests.blt | 19 ++-- src-literatetests/tests-context-free.blt | 16 +++- .../Brittany/Internal/LayouterBasics.hs | 4 + .../Haskell/Brittany/Internal/Layouters/IE.hs | 84 +++++++++--------- .../Brittany/Internal/Layouters/Import.hs | 87 ++++++++++--------- .../Brittany/Internal/Layouters/Module.hs | 80 ++++++++--------- .../Haskell/Brittany/Internal/Types.hs | 1 + 7 files changed, 159 insertions(+), 132 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index f1ea640..6b838a3 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -544,9 +544,14 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] -### + +############################################################################### +############################################################################### +############################################################################### #group module -### +############################################################################### +############################################################################### +############################################################################### #test simple module Main where @@ -603,9 +608,13 @@ module Main (Test()) where #test empty-with-comment -- Intentionally left empty -### -#group import -### +############################################################################### +############################################################################### +############################################################################### +#group module.import +############################################################################### +############################################################################### +############################################################################### #test simple-import import Data.List diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index b8b0c4a..c588436 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -593,9 +593,13 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] -### +############################################################################### +############################################################################### +############################################################################### #group module -### +############################################################################### +############################################################################### +############################################################################### #test simple module Main where @@ -652,9 +656,13 @@ module Main (Test()) where #test empty-with-comment -- Intentionally left empty -### +############################################################################### +############################################################################### +############################################################################### #group import -### +############################################################################### +############################################################################### +############################################################################### #test simple-import import Data.List diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 52c9e08..151dd65 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -42,6 +42,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , appSep , docCommaSep , docParenLSep + , docParenR , docTick , spacifyDocs , briDocMToPPM @@ -465,6 +466,9 @@ docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered docParenLSep = appSep $ docLit $ Text.pack "(" +docParenR :: ToBriDocM BriDocNumbered +docParenR = docLit $ Text.pack ")" + docTick :: ToBriDocM BriDocNumbered docTick = docLit $ Text.pack "'" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index e6b83b7..df1b6ff 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -11,7 +11,13 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types import RdrName (RdrName(..)) -import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import GHC ( unLoc + , runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + ) import HsSyn import Name import HsImpExp @@ -22,53 +28,53 @@ import BasicTypes import Language.Haskell.Brittany.Internal.Utils -layoutIE :: ToBriDoc IE -layoutIE lie@(L _ _ie) = - docWrapNode lie - $ let - ien = docLit $ rdrNameToText $ ieName _ie - in - case _ie of - IEVar _ -> ien - IEThingAbs _ -> ien - IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ (IEWildcard _) _ _ -> - docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ _ ns fs -> - let - prepareFL = - docLit . Text.pack . FastString.unpackFS . flLabel . unLoc - in - docSeq - $ [ien, docLit $ Text.pack "("] + #if MIN_VERSION_ghc(8,2,0) - ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText . ieLWrappedName) ns) +prepareName :: LIEWrappedName name -> Located name +prepareName = ieLWrappedName #else - ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText) ns) +prepareName :: Located name -> Located name +prepareName = id #endif - ++ intersperse docCommaSep (map (prepareFL) fs) - ) - ++ [docLit $ Text.pack ")"] - IEModuleContents n -> docSeq - [ docLit $ Text.pack "module" - , docSeparator - , docLit . Text.pack . moduleNameString $ unLoc n - ] - _ -> docEmpty + +layoutIE :: ToBriDoc IE +layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of + IEVar _ -> ien + IEThingAbs _ -> ien + IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ _ ns fs -> + docSeq + $ [ien, docLit $ Text.pack "("] + ++ ( intersperse docCommaSep + (map (docLit . lrdrNameToText . prepareName) ns) + ++ intersperse docCommaSep (map prepareFL fs) + ) + ++ [docLit $ Text.pack ")"] + where + prepareFL = docLit . Text.pack . FastString.unpackFS . flLabel . unLoc + IEModuleContents n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + where ien = docLit $ rdrNameToText $ ieName ie layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered layoutIEList lies = do ies <- mapM (docSharedWrapper layoutIE) lies case ies of - [] -> docLit $ Text.pack "()" - (x:xs) -> docAlt + [] -> docLit $ Text.pack "()" + xs@(x1:xr) -> docAlt [ docSeq - $ [docLit $ Text.pack "(", x] - ++ map (\x' -> docSeq [docCommaSep, x']) xs - ++ [docLit $ Text.pack ")"] + [ docLit $ Text.pack "(" + , docSeq $ List.intersperse docCommaSep xs + , docLit $ Text.pack ")" + ] , docLines - ( docSeq [docLit $ Text.pack "(", docSeparator, x] - : map (\x' -> docSeq [docCommaSep, x']) xs - ++ [docLit $ Text.pack ")"] + ( [docSeq [docParenLSep, x1]] + ++ [ docSeq [docCommaSep, x] | x <- xr ] + ++ [docParenR] ) ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 6bfd63f..ea5d49c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -8,7 +8,13 @@ import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Config.Types import RdrName (RdrName(..)) -import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import GHC ( unLoc + , runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + ) import HsSyn import Name import HsImpExp @@ -18,29 +24,36 @@ import BasicTypes import Language.Haskell.Brittany.Internal.Utils + + +#if MIN_VERSION_ghc(8,2,0) +prepPkg :: SourceText -> String +prepPkg rawN = + case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" +#else +prepPkg :: String -> String +prepPkg = id +#endif +#if MIN_VERSION_ghc(8,2,0) +prepModName :: Located e -> e +prepModName = unLoc +#else +prepModName :: e -> e +prepModName = id +#endif + layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of - ImportDecl _ (L _ modName) pkg src safe q False as llies -> + ImportDecl _ (L _ modName) pkg src safe q False as llies -> do let modNameT = Text.pack $ moduleNameString modName -#if MIN_VERSION_ghc(8,2,0) - prepPkg rawN = - case rawN of - SourceText n -> n - -- This would be odd to encounter and the - -- result will most certainly be wrong - NoSourceText -> "" -#else - prepPkg = id -#endif pkgNameT = Text.pack . prepPkg . sl_st <$> pkg -#if MIN_VERSION_ghc(8,2,0) - prepModName = unLoc -#else - prepModName = id -#endif + asT = Text.pack . moduleNameString . prepModName <$> as - sig = ColBindingLine (Just (Text.pack "import")) importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty @@ -52,26 +65,22 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of appSep $ docSeq [docLit (Text.pack "as"), docSeparator, docLit asT'] importIds = docSeq $ [appSep $ docLit modNameT, fromMaybe docEmpty (makeAs <$> asT)] - in - do - (hiding, ies) <- case llies of - Just (h, L _ lies) -> do - sies <- docSharedWrapper layoutIEList lies - return (h, sies) - Nothing -> return (False, docEmpty) - h <- docSharedWrapper - ( const - ( docSeq - [ docCols sig [importQualifiers, importIds] - , if hiding - then appSep $ docLit $ Text.pack "hiding" - else docEmpty - ] - ) - ) - () - docAlt - [ docSeq [h, docForceSingleline ies] - , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) + (hiding, ies) <- case llies of + Just (h, L _ lies) -> do + sies <- docSharedWrapper layoutIEList lies + return (h, sies) + Nothing -> return (False, docEmpty) + h <- docSharedWrapper + ( const + ( docSeq + [ docCols ColImport [importQualifiers, importIds] + , if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty ] + ) + ) + () + docAlt + [ docSeq [h, docForceSingleline ies] + , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) + ] _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 0093c46..d7ce6ea 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -21,53 +21,43 @@ import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.Brittany.Internal.Utils + + layoutModule :: ToBriDoc HsModule layoutModule lmod@(L _ mod') = do case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports - HsModule (Just n) les imports _ _ _ -> - let - tn = Text.pack $ moduleNameString $ unLoc n - in - do - cs <- do - anns <- mAsk - case ExactPrint.Types.mkAnnKey lmod `Map.lookup` anns of - Just mAnn -> return $ extractAllComments mAnn - Nothing -> return [] - (hasComments, es) <- case les of - Nothing -> return (False, docEmpty) - Just llies@(L _ lies) -> do - hasComments <- hasAnyCommentsBelow llies - return (hasComments, docWrapNode llies $ layoutIEList lies) - docLines - ( [ -- A pseudo node that serves merely to force documentation + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> do + let tn = Text.pack $ moduleNameString $ unLoc n + (hasComments, es) <- case les of + Nothing -> return (False, docEmpty) + Just llies@(L _ lies) -> do + hasComments <- hasAnyCommentsBelow llies + return (hasComments, docWrapNode llies $ layoutIEList lies) + docLines + $ docSeq + [ docWrapNode lmod $ docEmpty + -- A pseudo node that serves merely to force documentation -- before the node - docWrapNode lmod $ docEmpty - | [] /= cs - ] - ++ [ docAlt - ( [ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , appSep $ docForceSingleline es - , docLit $ Text.pack "where" - ] - | not hasComments - ] - ++ [ docLines - [ docAddBaseY BrIndentRegular $ docPar - ( docSeq - [ appSep $ docLit $ Text.pack "module" - , docLit tn - ] - ) - (docForceMultiline es) - , docLit $ Text.pack "where" - ] - ] - ) - ] - ++ map layoutImport imports - ) + , docAlt + ( [ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , appSep $ docForceSingleline es + , docLit $ Text.pack "where" + ] + | not hasComments + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + ( docSeq + [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docForceMultiline es) + , docLit $ Text.pack "where" + ] + ] + ) + ] + : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 557f9b3..2784c1d 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -178,6 +178,7 @@ data ColSig | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? + | ColImport -- TODO deriving (Eq, Ord, Data.Data.Data, Show) -- 2.30.2 From c3b6e172614eb53468fb8cec50000b99b3681c2b Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Mon, 18 Dec 2017 12:01:22 +0100 Subject: [PATCH 061/478] Improve layout for imports --- src-literatetests/10-tests.blt | 88 ++++++++------ src-literatetests/tests-context-free.blt | 79 +++++++------ .../Brittany/Internal/Layouters/Import.hs | 108 +++++++++++------- 3 files changed, 166 insertions(+), 109 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6b838a3..97a5463 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -617,22 +617,22 @@ module Main (Test()) where ############################################################################### #test simple-import -import Data.List +import Data.List #test simple-import-alias -import Data.List as L +import Data.List as L #test simple-qualified-import import qualified Data.List #test simple-qualified-import-alias -import qualified Data.List as L +import qualified Data.List as L #test simple-safe -import safe Data.List +import safe Data.List as L #test simple-source -import {-# SOURCE #-} Data.List +import {-# SOURCE #-} Data.List ( ) #test simple-safe-qualified import safe qualified Data.List @@ -643,48 +643,69 @@ import {-# SOURCE #-} safe qualified Data.List #test simple-qualified-package import qualified "base" Data.List +#test qualifier-effect +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List ( ) +import {-# SOURCE #-} safe qualified Data.List hiding ( ) + #test instances-only -import qualified Data.List () +import qualified Data.List ( ) #test one-element -import Data.List (nub) +import Data.List ( nub ) #test several-elements -import Data.List (nub, foldl', indexElem) +import Data.List ( nub + , foldl' + , indexElem + ) #test with-things -import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) +import Test ( T + , T2() + , T3(..) + , T4(T4) + , T5(T5, t5) + ) #test hiding -import Test hiding () -import Test as T hiding () +import Test hiding ( ) +import Test as T + hiding ( ) -#test horizontal-layout -import Data.List (nub) -import qualified Data.List as L (foldl') +#test long-module-name +import TestJustShortEnoughModuleNameLikeThisOne ( ) +import TestJustAbitToLongModuleNameLikeThisOneIs + ( ) -import Test (test) -import Main hiding - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI + as T + +import TestJustShortEnoughModuleNameLike hiding ( ) +import TestJustAbitToLongModuleNameLikeTh + hiding ( ) + +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe + ( ) + +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff + as T +import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" A + hiding ( ) #test import-with-comments -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -709,9 +730,10 @@ module Test where -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index c588436..f9b4eb6 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -665,25 +665,25 @@ module Main (Test()) where ############################################################################### #test simple-import -import Data.List +import Data.List #test simple-import-alias -import Data.List as L +import Data.List as L #test simple-qualified-import import qualified Data.List #test simple-qualified-import-alias -import qualified Data.List as L +import qualified Data.List as L #test simple-safe -import safe Data.List +import safe Data.List as L #test simple-source -import {-# SOURCE #-} Data.List +import {-# SOURCE #-} Data.List ( ) #test simple-safe-qualified -import safe qualified Data.List +import safe qualified Data.Lis hiding ( nub ) #test simple-safe-qualified-source import {-# SOURCE #-} safe qualified Data.List @@ -691,48 +691,56 @@ import {-# SOURCE #-} safe qualified Data.List #test simple-qualified-package import qualified "base" Data.List +#test qualifier-effect +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List ( ) +import {-# SOURCE #-} safe qualified Data.List hiding ( ) + #test instances-only -import qualified Data.List () +import qualified Data.List ( ) #test one-element -import Data.List (nub) +import Data.List ( nub ) #test several-elements -import Data.List (nub, foldl', indexElem) +import Data.List ( nub + , foldl' + , indexElem + ) #test with-things -import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) +import Test ( T + , T2() + , T3(..) + , T4(T4) + , T5(T5, t5) + ) #test hiding -import Test hiding () -import Test as T hiding () +import Test hiding ( ) +import Test as T + hiding ( ) -#test horizontal-layout -import Data.List (nub) -import qualified Data.List as L (foldl') - -import Test (test) -import Main hiding - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) +#test long-module-name +import TestJustShortEnoughModuleNameLikeThisOne ( ) +import TestJustAbitToLongModuleNameLikeThisOneIs + ( ) +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI + as T +import TestJustShortEnoughModuleNameLike hiding ( ) +import TestJustAbitToLongModuleNameLikeTh + hiding ( ) #test import-with-comments -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -757,12 +765,13 @@ module Test where -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index ea5d49c..83343bb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -7,17 +7,14 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Config.Types -import RdrName (RdrName(..)) -import GHC ( unLoc - , runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - , Located - ) +import RdrName ( RdrName(..) ) +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , Located + ) import HsSyn import Name -import HsImpExp import FieldLabel import qualified FastString import BasicTypes @@ -28,12 +25,11 @@ import Language.Haskell.Brittany.Internal.Utils #if MIN_VERSION_ghc(8,2,0) prepPkg :: SourceText -> String -prepPkg rawN = - case rawN of - SourceText n -> n - -- This would be odd to encounter and the - -- result will most certainly be wrong - NoSourceText -> "" +prepPkg rawN = case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" #else prepPkg :: String -> String prepPkg = id @@ -49,11 +45,26 @@ prepModName = id layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False as llies -> do + importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack let - modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - - asT = Text.pack . moduleNameString . prepModName <$> as + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + asT = Text.pack . moduleNameString . prepModName <$> as + (hiding, mlies) = case llies of + Just (h, L _ lies') -> (h, Just lies') + Nothing -> (False, Nothing) + minQLength = length "import qualified " + qLengthReal = + let qualifiedPart = if q then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = fromMaybe 0 ((+ 1) . Text.length <$> pkgNameT) + srcPart = if src then length "{-# SOURCE #-} " else 0 + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal + -- Cost in columns of importColumn + asCost = length "as " + bindingCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty @@ -61,26 +72,41 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty , fromMaybe docEmpty (appSep . docLit <$> pkgNameT) ] - makeAs asT' = - appSep $ docSeq [docLit (Text.pack "as"), docSeparator, docLit asT'] - importIds = - docSeq $ [appSep $ docLit modNameT, fromMaybe docEmpty (makeAs <$> asT)] - (hiding, ies) <- case llies of - Just (h, L _ lies) -> do - sies <- docSharedWrapper layoutIEList lies - return (h, sies) - Nothing -> return (False, docEmpty) - h <- docSharedWrapper - ( const - ( docSeq - [ docCols ColImport [importQualifiers, importIds] - , if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty - ] - ) - ) - () - docAlt - [ docSeq [h, docForceSingleline ies] - , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) - ] + modNameD = + docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT + hidDoc = + if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + importHead = docSeq [importQualifiers, modNameD] + Just lies = mlies + (ieH:ieT) = map layoutIE lies + makeIENode ie = docSeq [docCommaSep, ie] + bindings@(bindingsH:bindingsT) = + docSeq [docParenLSep, ieH] + : map makeIENode ieT + ++ [docSeq [docSeparator, docParenR]] + bindingsD = case mlies of + Nothing -> docSeq [docEmpty] + -- ..[hiding].( ) + Just [] -> docSeq [hidDoc, docParenLSep, docParenR] + -- ..[hiding].( b ) + Just [_] -> docSeq $ hidDoc : bindings + -- ..[hiding].( b + -- , b' + -- ) + Just _ -> + docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT + bindingLine = + docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD + case asT of + Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] + | otherwise -> docLines [importHead, asDoc, bindingLine] + where + enoughRoom = nameCost < importCol - asCost + asDoc = + docEnsureIndent (BrIndentSpecial (importCol - asCost)) + $ docSeq + $ [appSep $ docLit $ Text.pack "as", docLit n] + Nothing | enoughRoom -> docSeq [importHead, bindingLine] + | otherwise -> docLines [importHead, bindingLine] + where enoughRoom = nameCost < importCol - bindingCost _ -> docEmpty -- 2.30.2 From 8c3a9bec251eb80df64e5e6b5b539ebbff9d3f78 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 18 Dec 2017 18:56:50 +0100 Subject: [PATCH 062/478] Fix operators in import list --- src-literatetests/10-tests.blt | 1 + src-literatetests/tests-context-free.blt | 1 + src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 97a5463..6091095 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -666,6 +666,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , (+) ) #test hiding diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index f9b4eb6..7a004ce 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -714,6 +714,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , (+) ) #test hiding diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index df1b6ff..4333d8e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -59,7 +59,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of , docLit . Text.pack . moduleNameString $ unLoc n ] _ -> docEmpty - where ien = docLit $ rdrNameToText $ ieName ie + where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered layoutIEList lies = do -- 2.30.2 From eac17b1bf28637f608da973df7b137115b18bdc1 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 01:11:25 +0100 Subject: [PATCH 063/478] Also render comments on the binding list --- .../Haskell/Brittany/Internal/Layouters/Import.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 83343bb..4f00f00 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -44,13 +44,13 @@ prepModName = id layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of - ImportDecl _ (L _ modName) pkg src safe q False as llies -> do + ImportDecl _ (L _ modName) pkg src safe q False as mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack let modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg asT = Text.pack . moduleNameString . prepModName <$> as - (hiding, mlies) = case llies of + (hiding, mlies) = case mllies of Just (h, L _ lies') -> (h, Just lies') Nothing -> (False, Nothing) minQLength = length "import qualified " @@ -78,6 +78,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] Just lies = mlies + Just (_, llies) = mllies (ieH:ieT) = map layoutIE lies makeIENode ie = docSeq [docCommaSep, ie] bindings@(bindingsH:bindingsT) = @@ -93,8 +94,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of -- ..[hiding].( b -- , b' -- ) - Just _ -> - docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT + Just _ -> docWrapNode llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of -- 2.30.2 From 7c51a181c8af97bd1b9ac8f50eca2e98cb351d9d Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 01:17:19 +0100 Subject: [PATCH 064/478] Fix operators for ThingWith --- src-literatetests/10-tests.blt | 1 + src-literatetests/tests-context-free.blt | 1 + src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6091095..8c5b547 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -666,6 +666,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , T6((<|>)) , (+) ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 7a004ce..5f21502 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -714,6 +714,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , T6((<|>)) , (+) ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 4333d8e..9876f01 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -47,7 +47,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of docSeq $ [ien, docLit $ Text.pack "("] ++ ( intersperse docCommaSep - (map (docLit . lrdrNameToText . prepareName) ns) + (map ((docLit =<<) . lrdrNameToTextAnn . prepareName) ns) ++ intersperse docCommaSep (map prepareFL fs) ) ++ [docLit $ Text.pack ")"] -- 2.30.2 From a59df1f3913344768e4d5d2b7835652e787eecef Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 14:28:22 +0100 Subject: [PATCH 065/478] Fix comments!! :hooray: --- src-literatetests/10-tests.blt | 23 +++++++++++ src-literatetests/tests-context-free.blt | 23 +++++++++++ .../Brittany/Internal/Layouters/Import.hs | 41 +++++++++++++++---- 3 files changed, 79 insertions(+), 8 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 8c5b547..6b49e57 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -709,6 +709,29 @@ import qualified Data.List as L -- Test import Test ( test ) +#test import-with-comments-2 + +import Test ( abc + , def + -- comment + ) + +#test import-with-comments-3 + +import Test ( abc + -- comment + ) + +#test import-with-comments-4 +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 5f21502..1bc25ac 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -741,6 +741,29 @@ import Data.List ( nub ) -- Test import qualified Data.List as L ( foldl' ) {- Test -} +#test import-with-comments-2 + +import Test ( abc + , def + -- comment + ) + +#test import-with-comments-3 + +import Test ( abc + -- comment + ) + +#test import-with-comments-4 +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) + -- Test import Test ( test ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 4f00f00..e2ba394 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -76,25 +76,50 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty - importHead = docSeq [importQualifiers, modNameD] - Just lies = mlies + importHead = docSeq [importQualifiers, modNameD] + Just lies = mlies Just (_, llies) = mllies - (ieH:ieT) = map layoutIE lies + (ieH:ieT) = map layoutIE lies makeIENode ie = docSeq [docCommaSep, ie] bindings@(bindingsH:bindingsT) = docSeq [docParenLSep, ieH] - : map makeIENode ieT + : bindingsT' ++ [docSeq [docSeparator, docParenR]] + where + -- Handle the last element with docWrapNode llies + bindingsT' = + case ieT of + [] -> [] + [ie] -> [makeIENode $ docWrapNode llies $ ie] + _ -> map makeIENode (List.init ieT) ++ [makeIENode $ docWrapNode llies $ List.last ieT] bindingsD = case mlies of - Nothing -> docSeq [docEmpty] + Nothing -> docSeq [docEmpty] -- ..[hiding].( ) - Just [] -> docSeq [hidDoc, docParenLSep, docParenR] + Just [] -> do + hasComments <- hasAnyCommentsBelow llies + if hasComments + then + docWrapNodeRest llies + $ docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + $ docLines [docParenR] + else + docWrapNodeRest llies $ docSeq [hidDoc, docParenLSep, docParenR] -- ..[hiding].( b ) - Just [_] -> docSeq $ hidDoc : bindings + Just [_] -> do + hasComments <- hasAnyCommentsBelow llies + if hasComments + then + docWrapNodeRest llies $ docPar (docSeq [hidDoc, docWrapNode llies $ bindingsH]) $ docLines + bindingsT + else + docWrapNodeRest llies $ docSeq $ hidDoc : bindings -- ..[hiding].( b -- , b' -- ) - Just _ -> docWrapNode llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT + Just _ -> + docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) + $ docLines bindingsT bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of -- 2.30.2 From bcdd05848569c5381eeebf43558b31b1d8007758 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 19 Dec 2017 15:28:52 +0100 Subject: [PATCH 066/478] Update README.md for stackage lts release --- README.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 3196b27..c7bd461 100644 --- a/README.md +++ b/README.md @@ -52,7 +52,7 @@ log the size of the input, but _not_ the full requests.) # Other usage notes - Supports GHC versions `8.0.*` and `8.2.*`. -- as of November'17, `brittany` is available on stackage nightly. +- included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. - uses/creates user config file in `~/.config/brittany/config.yaml`; @@ -84,11 +84,11 @@ log the size of the input, but _not_ the full requests.) - via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) ~~~~.sh - stack install brittany # --resolver=nightly-2017-11-15 + stack install brittany # --resolver lts-10.0 ~~~~ - (alternatively, should nightlies be unreliable, or you want to use ghc-8.0 or something, then - cloning the repo and doing `stack install` will use an lts resolver.) + (earlier ltss did not include `brittany` yet, but the repo should contain a + `stack.yaml` that works with ghc-8.0.) - on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`: -- 2.30.2 From 162b6e6bfda6fc64b6f5fc28345bca41fab383d7 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 16:33:13 +0100 Subject: [PATCH 067/478] Also fix export comments Also refactored a little to improve reuse of the docWrapNode logic --- src-literatetests/10-tests.blt | 11 +++ src-literatetests/tests-context-free.blt | 10 +++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 57 +++++++++----- .../Brittany/Internal/Layouters/Import.hs | 75 ++++++++----------- .../Brittany/Internal/Layouters/Module.hs | 4 +- 5 files changed, 94 insertions(+), 63 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6b49e57..e560296 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -583,6 +583,7 @@ where #test exports-with-comments module Main ( main + -- main , test1 , test2 -- Test 3 @@ -590,6 +591,7 @@ module Main , test4 -- Test 5 , test5 + -- Test 6 ) where @@ -732,6 +734,14 @@ import Test ( abc -- comment ) +#test import-with-comments-5 +import Test ( -- comment + ) + +#test long-bindings +import Test ( longbindingNameThatoverflowsColum ) +import Test ( Long(List, Of, Things) ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -751,6 +761,7 @@ module Test , test8 , test9 , test10 + -- Test 10 ) where diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 1bc25ac..8be4666 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -631,6 +631,7 @@ where #test exports-with-comments module Main ( main + -- main , test1 , test2 -- Test 3 @@ -638,6 +639,7 @@ module Main , test4 -- Test 5 , test5 + -- Test 6 ) where @@ -767,6 +769,14 @@ import Test ( abc -- Test import Test ( test ) +#test import-with-comments-5 +import Test ( -- comment + ) + +#test long-bindings +import Test ( longbindingNameThatoverflowsColum ) +import Test ( Long(List, Of, Things) ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 9876f01..bf87b6d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -1,6 +1,7 @@ module Language.Haskell.Brittany.Internal.Layouters.IE ( layoutIE - , layoutIEList + , layoutLLIEs + , layoutAnnAndSepLLIEs ) where @@ -61,20 +62,42 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) -layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered -layoutIEList lies = do - ies <- mapM (docSharedWrapper layoutIE) lies - case ies of - [] -> docLit $ Text.pack "()" - xs@(x1:xr) -> docAlt - [ docSeq - [ docLit $ Text.pack "(" - , docSeq $ List.intersperse docCommaSep xs - , docLit $ Text.pack ")" +-- Helper function to deal with Located lists of LIEs. +-- In particular this will also associate documentation +-- from the LIES that actually belongs to the last IE. +-- It also add docCommaSep to all but he last element +-- This configuration allows both vertical and horizontal +-- handling of the resulting list. Adding parens is +-- left to the caller since that is context sensitive +layoutAnnAndSepLLIEs :: (Located [LIE RdrName]) -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs llies@(L _ lies) = do + let makeIENode ie = docSeq [docCommaSep, ie] + layoutAnnAndSepLLIEs' ies = case ies of + [] -> [] + [ie] -> [docWrapNode llies $ ie] + (ie:ies') -> ie:map makeIENode (List.init ies') + ++ [makeIENode $ docWrapNode llies $ List.last ies'] + layoutAnnAndSepLLIEs' <$> mapM (docSharedWrapper layoutIE) lies + +-- Builds a complete layout for the given located +-- list of LIEs. The layout provides two alternatives: +-- (item, item, ..., item) +-- ( item +-- , item +-- ... +-- , item +-- ) +-- Empty lists will always be rendered as () +layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs llies = docWrapNodeRest llies $ do + ieDs <- layoutAnnAndSepLLIEs llies + case ieDs of + [] -> docLit $ Text.pack "()" + ieDs@(ieDsH:ieDsT) -> + docAlt + [ docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR] + , docLines $ + docSeq [docParenLSep, ieDsH] + : ieDsT + ++ [docParenR] ] - , docLines - ( [docSeq [docParenLSep, x1]] - ++ [ docSeq [docCommaSep, x] | x <- xr ] - ++ [docParenR] - ) - ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index e2ba394..cc4172f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -50,9 +50,9 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg asT = Text.pack . moduleNameString . prepModName <$> as - (hiding, mlies) = case mllies of - Just (h, L _ lies') -> (h, Just lies') - Nothing -> (False, Nothing) + hiding = case mllies of + Just (h, _) -> h + Nothing -> False minQLength = length "import qualified " qLengthReal = let qualifiedPart = if q then length "qualified " else 0 @@ -77,49 +77,36 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] - Just lies = mlies - Just (_, llies) = mllies - (ieH:ieT) = map layoutIE lies - makeIENode ie = docSeq [docCommaSep, ie] - bindings@(bindingsH:bindingsT) = - docSeq [docParenLSep, ieH] - : bindingsT' - ++ [docSeq [docSeparator, docParenR]] - where - -- Handle the last element with docWrapNode llies - bindingsT' = - case ieT of - [] -> [] - [ie] -> [makeIENode $ docWrapNode llies $ ie] - _ -> map makeIENode (List.init ieT) ++ [makeIENode $ docWrapNode llies $ List.last ieT] - bindingsD = case mlies of + bindingsH = docParenLSep + bindingsT = [docSeq [docSeparator, docParenR]] + bindingsD = case mllies of Nothing -> docSeq [docEmpty] - -- ..[hiding].( ) - Just [] -> do + Just (_, llies) -> do + ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - if hasComments - then - docWrapNodeRest llies - $ docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - $ docLines [docParenR] - else - docWrapNodeRest llies $ docSeq [hidDoc, docParenLSep, docParenR] - -- ..[hiding].( b ) - Just [_] -> do - hasComments <- hasAnyCommentsBelow llies - if hasComments - then - docWrapNodeRest llies $ docPar (docSeq [hidDoc, docWrapNode llies $ bindingsH]) $ docLines - bindingsT - else - docWrapNodeRest llies $ docSeq $ hidDoc : bindings - -- ..[hiding].( b - -- , b' - -- ) - Just _ -> - docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) - $ docLines bindingsT + case ieDs of + -- ..[hiding].( ) + [] -> do + if hasComments + then + docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, docWrapNode llies docEmpty]) $ docLines + bindingsT + else + docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : bindingsT + -- ..[hiding].( b ) + [ieD] -> do + if hasComments + then + docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, ieD ]) $ docLines $ + bindingsT + else + docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : ieD : bindingsT + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> do + docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ docSeq [bindingsH, ieD]]) + $ docLines $ ieDs' ++ bindingsT bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index d7ce6ea..509b24a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -32,9 +32,9 @@ layoutModule lmod@(L _ mod') = do let tn = Text.pack $ moduleNameString $ unLoc n (hasComments, es) <- case les of Nothing -> return (False, docEmpty) - Just llies@(L _ lies) -> do + Just llies -> do hasComments <- hasAnyCommentsBelow llies - return (hasComments, docWrapNode llies $ layoutIEList lies) + return (hasComments, layoutLLIEs llies) docLines $ docSeq [ docWrapNode lmod $ docEmpty -- 2.30.2 From ce7ec0b4679d5fd3cb8a2e51a67752d34dd2390b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 19 Dec 2017 17:52:33 +0100 Subject: [PATCH 068/478] Fix warning --- src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bf87b6d..3daf877 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -93,7 +93,7 @@ layoutLLIEs llies = docWrapNodeRest llies $ do ieDs <- layoutAnnAndSepLLIEs llies case ieDs of [] -> docLit $ Text.pack "()" - ieDs@(ieDsH:ieDsT) -> + (ieDsH:ieDsT) -> docAlt [ docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR] , docLines $ -- 2.30.2 From 5dac6dd7f214d3281f66bdcdefcf6da54bd9cd9f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 19 Dec 2017 17:25:34 +0100 Subject: [PATCH 069/478] Add ghc-option -Werror to all builds in .travis.yml --- .travis.yml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 58a0f33..dbe5dfc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -250,6 +250,8 @@ install: cabal --version travis_retry cabal update -v echo 'packages: .' > cabal.project + echo 'package brittany' > cabal.project.local + echo ' ghc-options: -Werror' >> cabal.project.local rm -f cabal.project.freeze cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep @@ -262,12 +264,12 @@ script: set -ex case "$BUILD" in stack) - better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS" + better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror" ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging - better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" # this builds all libraries and executables (including tests/benchmarks) + better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) cabal test ;; cabaldist) -- 2.30.2 From ac10b903af3d6814dc52e78e8ad52a81a20d3ee1 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 19 Dec 2017 20:05:55 +0100 Subject: [PATCH 070/478] travis.yml: Set jobs to 1, Pass to stack --- .travis.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index dbe5dfc..e1c64bf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -178,7 +178,7 @@ before_install: # echo 'jobs: $ncpus' >> $HOME/.cabal/config #fi - PKGNAME='brittany' -- JOBS='2' +- JOBS='1' - | function better_wait() { date @@ -209,7 +209,7 @@ install: set -ex case "$BUILD" in stack) - stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies + stack -j$JOBS --no-terminal --install-ghc $ARGS test --bench --only-dependencies ;; cabal*) cabal --version @@ -264,7 +264,7 @@ script: set -ex case "$BUILD" in stack) - better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror" + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror" ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi -- 2.30.2 From 33f23a65ec44d70aecde50dcdaf16b09a4f8c470 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Dec 2017 15:44:58 +0100 Subject: [PATCH 071/478] Refactor and Add missing docSharedWrapper --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 15 +++-- .../Brittany/Internal/Layouters/Import.hs | 55 +++++++++---------- .../Brittany/Internal/Layouters/Module.hs | 11 ++-- 3 files changed, 41 insertions(+), 40 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 3daf877..926f642 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -71,12 +71,15 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs :: (Located [LIE RdrName]) -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs llies@(L _ lies) = do - let makeIENode ie = docSeq [docCommaSep, ie] - layoutAnnAndSepLLIEs' ies = case ies of - [] -> [] - [ie] -> [docWrapNode llies $ ie] - (ie:ies') -> ie:map makeIENode (List.init ies') - ++ [makeIENode $ docWrapNode llies $ List.last ies'] + let + makeIENode ie = docSeq [docCommaSep, ie] + layoutAnnAndSepLLIEs' ies = case splitFirstLast ies of + FirstLastEmpty -> [] + FirstLastSingleton ie -> [docWrapNodeRest llies $ ie] + FirstLast ie1 ieMs ieN -> + [ie1] + ++ map makeIENode ieMs + ++ [makeIENode $ docWrapNodeRest llies $ ieN] layoutAnnAndSepLLIEs' <$> mapM (docSharedWrapper layoutIE) lies -- Builds a complete layout for the given located diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index cc4172f..7aac868 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -46,13 +46,16 @@ layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False as mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + -- NB we don't need to worry about sharing in the below code + -- (docSharedWrapper etc.) because we do not use any docAlt nodes; all + -- "decisions" are made statically. let - modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - asT = Text.pack . moduleNameString . prepModName <$> as - hiding = case mllies of + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + asT = Text.pack . moduleNameString . prepModName <$> as + hiding = case mllies of Just (h, _) -> h - Nothing -> False + Nothing -> False minQLength = length "import qualified " qLengthReal = let qualifiedPart = if q then length "qualified " else 0 @@ -76,37 +79,31 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty - importHead = docSeq [importQualifiers, modNameD] - bindingsH = docParenLSep - bindingsT = [docSeq [docSeparator, docParenR]] - bindingsD = case mllies of - Nothing -> docSeq [docEmpty] + importHead = docSeq [importQualifiers, modNameD] + bindingsD = case mllies of + Nothing -> docSeq [docEmpty] Just (_, llies) -> do - ieDs <- layoutAnnAndSepLLIEs llies + ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - case ieDs of + docWrapNodeRest llies $ case ieDs of -- ..[hiding].( ) - [] -> do - if hasComments - then - docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, docWrapNode llies docEmpty]) $ docLines - bindingsT - else - docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : bindingsT + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + docParenR + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] -- ..[hiding].( b ) - [ieD] -> do - if hasComments - then - docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, ieD ]) $ docLines $ - bindingsT - else - docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : ieD : bindingsT + [ieD] -> if hasComments + then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR + else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] -- ..[hiding].( b -- , b' -- ) - (ieD:ieDs') -> do - docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ docSeq [bindingsH, ieD]]) - $ docLines $ ieDs' ++ bindingsT + (ieD:ieDs') -> + docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + $ docLines + $ ieDs' + ++ [docParenR] bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 509b24a..c0f569b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -30,11 +30,12 @@ layoutModule lmod@(L _ mod') = do HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports HsModule (Just n) les imports _ _ _ -> do let tn = Text.pack $ moduleNameString $ unLoc n - (hasComments, es) <- case les of - Nothing -> return (False, docEmpty) + (hasComments, exportsDoc) <- case les of + Nothing -> return (False, docEmpty) Just llies -> do hasComments <- hasAnyCommentsBelow llies - return (hasComments, layoutLLIEs llies) + exportsDoc <- docSharedWrapper layoutLLIEs llies + return (hasComments, exportsDoc) docLines $ docSeq [ docWrapNode lmod $ docEmpty @@ -44,7 +45,7 @@ layoutModule lmod@(L _ mod') = do ( [ docSeq [ appSep $ docLit $ Text.pack "module" , appSep $ docLit tn - , appSep $ docForceSingleline es + , appSep $ docForceSingleline exportsDoc , docLit $ Text.pack "where" ] | not hasComments @@ -54,7 +55,7 @@ layoutModule lmod@(L _ mod') = do ( docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) - (docForceMultiline es) + (docForceMultiline exportsDoc) , docLit $ Text.pack "where" ] ] -- 2.30.2 From 82a5ffb3b3ce02f4370784e416c999518bd07d5a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Dec 2017 17:56:54 +0100 Subject: [PATCH 072/478] Refactor a bit more - remove unnecessary docWrapNodeRest - make sure that sharing is correct and non-redundant --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 926f642..bce0a4a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -69,18 +69,18 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- This configuration allows both vertical and horizontal -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive -layoutAnnAndSepLLIEs :: (Located [LIE RdrName]) -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs + :: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs llies@(L _ lies) = do - let - makeIENode ie = docSeq [docCommaSep, ie] - layoutAnnAndSepLLIEs' ies = case splitFirstLast ies of + let makeIENode ie = docSeq [docCommaSep, ie] + let ieDocs = layoutIE <$> lies + ieCommaDocs <- + docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of FirstLastEmpty -> [] - FirstLastSingleton ie -> [docWrapNodeRest llies $ ie] + FirstLastSingleton ie -> [ie] FirstLast ie1 ieMs ieN -> - [ie1] - ++ map makeIENode ieMs - ++ [makeIENode $ docWrapNodeRest llies $ ieN] - layoutAnnAndSepLLIEs' <$> mapM (docSharedWrapper layoutIE) lies + [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] + pure $ fmap pure ieCommaDocs -- returned shared nodes -- Builds a complete layout for the given located -- list of LIEs. The layout provides two alternatives: @@ -92,7 +92,7 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- ) -- Empty lists will always be rendered as () layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered -layoutLLIEs llies = docWrapNodeRest llies $ do +layoutLLIEs llies = do ieDs <- layoutAnnAndSepLLIEs llies case ieDs of [] -> docLit $ Text.pack "()" -- 2.30.2 From f920f4714d976cef33b3557fc098e152879f9991 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Dec 2017 21:45:29 +0100 Subject: [PATCH 073/478] Fix maximum on empty list, fixes #88 --- src/Language/Haskell/Brittany/Internal/Backend.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 44264d4..c121eaf 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -352,7 +352,11 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- maxZipper xs [] = xs -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr colAggregation :: [Int] -> Int - colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ] + colAggregation [] = 0 -- this probably cannot happen the way we call + -- this function, because _cbs_map only ever + -- contains nonempty Seqs. + colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ] + where alignMax' = max 0 alignMax processedMap :: ColMap2 processedMap = -- 2.30.2 From 21c080572b39fb4307edfe19107998a2a2b4f2d9 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Thu, 21 Dec 2017 23:51:27 +0100 Subject: [PATCH 074/478] Add compact version of import layout Also let layoutLLIEs deal with comments --- src-literatetests/10-tests.blt | 11 ++ src-literatetests/tests-context-free.blt | 117 ++++++++---------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 34 ++--- .../Brittany/Internal/Layouters/Import.hs | 93 ++++++++------ .../Brittany/Internal/Layouters/Module.hs | 18 +-- 5 files changed, 144 insertions(+), 129 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 123eccc..758efe0 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -704,6 +704,17 @@ import TestJustShortEnoughModuleNameLike hiding ( ) import TestJustAbitToLongModuleNameLikeTh hiding ( ) +import MoreThanSufficientlyLongModuleNameWithSome + ( items + , that + , will + , not + , fit + , inA + , compact + , layout + ) + import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe ( ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 8be4666..a48890a 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -667,25 +667,25 @@ module Main (Test()) where ############################################################################### #test simple-import -import Data.List +import Data.List #test simple-import-alias -import Data.List as L +import Data.List as L #test simple-qualified-import import qualified Data.List #test simple-qualified-import-alias -import qualified Data.List as L +import qualified Data.List as L #test simple-safe -import safe Data.List as L +import safe Data.List as L #test simple-source -import {-# SOURCE #-} Data.List ( ) +import {-# SOURCE #-} Data.List () #test simple-safe-qualified -import safe qualified Data.Lis hiding ( nub ) +import safe qualified Data.List hiding (nub) #test simple-safe-qualified-source import {-# SOURCE #-} safe qualified Data.List @@ -694,88 +694,82 @@ import {-# SOURCE #-} safe qualified Data.List import qualified "base" Data.List #test qualifier-effect -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List ( ) -import {-# SOURCE #-} safe qualified Data.List hiding ( ) +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List () +import {-# SOURCE #-} safe qualified Data.List hiding () #test instances-only -import qualified Data.List ( ) +import qualified Data.List () #test one-element -import Data.List ( nub ) +import Data.List (nub) #test several-elements -import Data.List ( nub - , foldl' - , indexElem - ) +import Data.List (nub, foldl', indexElem) #test with-things -import Test ( T - , T2() - , T3(..) - , T4(T4) - , T5(T5, t5) - , T6((<|>)) - , (+) - ) +import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) #test hiding -import Test hiding ( ) -import Test as T - hiding ( ) +import Test hiding () +import Test as T hiding () #test long-module-name -import TestJustShortEnoughModuleNameLikeThisOne ( ) -import TestJustAbitToLongModuleNameLikeThisOneIs - ( ) -import TestJustShortEnoughModuleNameLikeThisOn as T -import TestJustAbitToLongModuleNameLikeThisOneI - as T -import TestJustShortEnoughModuleNameLike hiding ( ) -import TestJustAbitToLongModuleNameLikeTh - hiding ( ) +import TestJustShortEnoughModuleNameLikeThisOne () +import TestJustAbitToLongModuleNameLikeThisOneIs () +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLike hiding () +import TestJustAbitToLongModuleNameLikeTh hiding () +import MoreThanSufficientlyLongModuleNameWithSome ( items + , that + , will + , not + , fit + , inA + , compact + , layout + ) #test import-with-comments -- Test -import Data.List ( nub ) -- Test +import Data.List (nub) -- Test {- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} +import qualified Data.List as L (foldl') {- Test -} #test import-with-comments-2 -import Test ( abc - , def - -- comment - ) +import Test ( abc + , def + -- comment + ) #test import-with-comments-3 -import Test ( abc - -- comment - ) +import Test ( abc + -- comment + ) #test import-with-comments-4 -import Test ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) -- Test -import Test ( test ) +import Test (test) #test import-with-comments-5 -import Test ( -- comment - ) +import Test ( -- comment + ) #test long-bindings -import Test ( longbindingNameThatoverflowsColum ) -import Test ( Long(List, Of, Things) ) +import Test (longbindingNameThatoverflowsColum) +import Test (Long(List, Of, Things)) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -800,13 +794,12 @@ module Test where -- Test -import Data.List ( nub ) -- Test +import Data.List (nub) -- Test {- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} +import qualified Data.List as L (foldl') {- Test -} -- Test -import Test ( test ) +import Test (test) ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bce0a4a..262108e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -47,12 +47,10 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingWith _ _ ns fs -> docSeq $ [ien, docLit $ Text.pack "("] - ++ ( intersperse docCommaSep - (map ((docLit =<<) . lrdrNameToTextAnn . prepareName) ns) - ++ intersperse docCommaSep (map prepareFL fs) - ) + ++ intersperse docCommaSep (map nameDoc ns ++ map prepareFL fs) ++ [docLit $ Text.pack ")"] where + nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName prepareFL = docLit . Text.pack . FastString.unpackFS . flLabel . unLoc IEModuleContents n -> docSeq [ docLit $ Text.pack "module" @@ -64,8 +62,8 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation --- from the LIES that actually belongs to the last IE. --- It also add docCommaSep to all but he last element +-- from the located list that actually belongs to the last IE. +-- It also adds docCommaSep to all but the first element -- This configuration allows both vertical and horizontal -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive @@ -90,17 +88,25 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- ... -- , item -- ) --- Empty lists will always be rendered as () +-- If the llies contains comments the list will +-- always expand over multiple lines, even when empty: +-- () -- no comments +-- ( -- a comment +-- ) layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered layoutLLIEs llies = do ieDs <- layoutAnnAndSepLLIEs llies + hasComments <- hasAnyCommentsBelow llies case ieDs of - [] -> docLit $ Text.pack "()" + [] -> docAltFilter + [ (not hasComments, docLit $ Text.pack "()") + , (otherwise, docPar (docSeq [docParenLSep, docWrapNode llies docEmpty]) + $ docLines [docParenR]) + ] (ieDsH:ieDsT) -> - docAlt - [ docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR] - , docLines $ - docSeq [docParenLSep, ieDsH] - : ieDsT - ++ [docParenR] + docAltFilter + [ (not hasComments, docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR]) + , (otherwise, docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ + docLines $ ieDsT + ++ [docParenR]) ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 7aac868..97284a8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -44,23 +44,23 @@ prepModName = id layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of - ImportDecl _ (L _ modName) pkg src safe q False as mllies -> do + ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack -- NB we don't need to worry about sharing in the below code -- (docSharedWrapper etc.) because we do not use any docAlt nodes; all -- "decisions" are made statically. let + compact = indentPolicy == IndentPolicyLeft modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - asT = Text.pack . moduleNameString . prepModName <$> as - hiding = case mllies of - Just (h, _) -> h - Nothing -> False + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = let qualifiedPart = if q then length "qualified " else 0 safePart = if safe then length "safe " else 0 - pkgPart = fromMaybe 0 ((+ 1) . Text.length <$> pkgNameT) + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT srcPart = if src then length "{-# SOURCE #-} " else 0 in length "import " + srcPart + safePart + qualifiedPart + pkgPart qLength = max minQLength qLengthReal @@ -73,49 +73,60 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty - , fromMaybe docEmpty (appSep . docLit <$> pkgNameT) + , maybe docEmpty (appSep . docLit) pkgNameT ] + indentName = + if compact then id else docEnsureIndent (BrIndentSpecial qLength) modNameD = - docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT + indentName $ appSep $ docLit modNameT hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] bindingsD = case mllies of - Nothing -> docSeq [docEmpty] + Nothing -> docEmpty Just (_, llies) -> do - ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - docWrapNodeRest llies $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - docParenR - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> if hasComments - then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR - else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - $ docLines - $ ieDs' - ++ [docParenR] + if compact + then docSeq [hidDoc, layoutLLIEs llies] + else do + ieDs <- layoutAnnAndSepLLIEs llies + docWrapNodeRest llies $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + docParenR + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> if hasComments + then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR + else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + $ docLines + $ ieDs' + ++ [docParenR] bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD - case asT of - Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] - | otherwise -> docLines [importHead, asDoc, bindingLine] - where - enoughRoom = nameCost < importCol - asCost - asDoc = - docEnsureIndent (BrIndentSpecial (importCol - asCost)) - $ docSeq - $ [appSep $ docLit $ Text.pack "as", docLit n] - Nothing | enoughRoom -> docSeq [importHead, bindingLine] - | otherwise -> docLines [importHead, bindingLine] - where enoughRoom = nameCost < importCol - bindingCost + makeAsDoc asT = + docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] + if compact + then + let asDoc = maybe docEmpty makeAsDoc masT + in docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + else + case masT of + Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] + | otherwise -> docLines [importHead, asDoc, bindingLine] + where + enoughRoom = nameCost < importCol - asCost + asDoc = + docEnsureIndent (BrIndentSpecial (importCol - asCost)) + $ makeAsDoc n + Nothing | enoughRoom -> docSeq [importHead, bindingLine] + | otherwise -> docLines [importHead, bindingLine] + where enoughRoom = nameCost < importCol - bindingCost _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index c0f569b..db2e2af 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -24,31 +24,25 @@ import Language.Haskell.Brittany.Internal.Utils layoutModule :: ToBriDoc HsModule -layoutModule lmod@(L _ mod') = do +layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports HsModule (Just n) les imports _ _ _ -> do - let tn = Text.pack $ moduleNameString $ unLoc n - (hasComments, exportsDoc) <- case les of - Nothing -> return (False, docEmpty) - Just llies -> do - hasComments <- hasAnyCommentsBelow llies - exportsDoc <- docSharedWrapper layoutLLIEs llies - return (hasComments, exportsDoc) + let tn = Text.pack $ moduleNameString $ unLoc n + exportsDoc = maybe docEmpty layoutLLIEs les docLines $ docSeq - [ docWrapNode lmod $ docEmpty + [ docWrapNode lmod docEmpty -- A pseudo node that serves merely to force documentation -- before the node , docAlt - ( [ docSeq + ( [ docForceSingleline $ docSeq [ appSep $ docLit $ Text.pack "module" , appSep $ docLit tn - , appSep $ docForceSingleline exportsDoc + , appSep exportsDoc , docLit $ Text.pack "where" ] - | not hasComments ] ++ [ docLines [ docAddBaseY BrIndentRegular $ docPar -- 2.30.2 From 3708838b6a4a7618afbadb5182d81ff2fa9ad5e8 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 06:58:39 +0100 Subject: [PATCH 075/478] Also handle comments inside ThingWith --- src-literatetests/10-tests.blt | 22 ++++++++++++- src-literatetests/tests-context-free.blt | 22 +++++++++++++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 32 +++++++++++++++---- 3 files changed, 68 insertions(+), 8 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 758efe0..7164f77 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -765,7 +765,27 @@ import Test ( -- comment #test long-bindings import Test ( longbindingNameThatoverflowsColum ) -import Test ( Long(List, Of, Things) ) +import Test ( Long( List + , Of + , Things + ) ) + +#test things-with-with-comments +import Test ( Thing( -- Comments + ) + ) +import Test ( Thing( Item + -- and Comment + ) + ) +import Test ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index a48890a..2795da8 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -771,6 +771,28 @@ import Test ( -- comment import Test (longbindingNameThatoverflowsColum) import Test (Long(List, Of, Things)) +#test things-with-with-comments +import Test ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +import Test ( Thing( Item + -- and Comment + ) + ) +import Test ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 262108e..85a4ef8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -44,14 +44,32 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingAbs _ -> ien IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ _ ns fs -> - docSeq - $ [ien, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc ns ++ map prepareFL fs) - ++ [docLit $ Text.pack ")"] + IEThingWith _ _ ns _ -> do + hasComments <- hasAnyCommentsBelow lie + docAltFilter + [(not hasComments, docSeq $ [ien, docLit $ Text.pack "("] + ++ intersperse docCommaSep (map nameDoc ns) + ++ [docParenR]) + ,(otherwise, docSeq [ien, layoutItems (splitFirstLast ns)]) + ] where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName - prepareFL = docLit . Text.pack . FastString.unpackFS . flLabel . unLoc + layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] + layoutItems FirstLastEmpty = + docSetBaseY $ + docLines [docSeq [docParenLSep, docWrapNodeRest lie docEmpty] + ,docParenR + ] + layoutItems (FirstLastSingleton n) = + docSetBaseY $ docLines + [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR] + layoutItems (FirstLast n1 nMs nN) = + docSetBaseY $ docLines $ + [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + ++ map layoutItem nMs + ++ [ docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN] + , docParenR + ] IEModuleContents n -> docSeq [ docLit $ Text.pack "module" , docSeparator @@ -101,7 +119,7 @@ layoutLLIEs llies = do [] -> docAltFilter [ (not hasComments, docLit $ Text.pack "()") , (otherwise, docPar (docSeq [docParenLSep, docWrapNode llies docEmpty]) - $ docLines [docParenR]) + docParenR) ] (ieDsH:ieDsT) -> docAltFilter -- 2.30.2 From ad34a8b9b99a277c4ba11413a08fdc21ea85ce41 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 10:08:30 +0100 Subject: [PATCH 076/478] Only expand empty binding list with comments --- src-literatetests/10-tests.blt | 3 +++ src-literatetests/tests-context-free.blt | 3 +++ src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 7 +++++-- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 7164f77..95d8593 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -786,6 +786,9 @@ import Test ( Thing( With -- ! ) ) +#test prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + ( ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 2795da8..6e8c523 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -793,6 +793,9 @@ import Test ( Thing( With ) ) +#test prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine () + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 85a4ef8..ebf9b36 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -118,8 +118,11 @@ layoutLLIEs llies = do case ieDs of [] -> docAltFilter [ (not hasComments, docLit $ Text.pack "()") - , (otherwise, docPar (docSeq [docParenLSep, docWrapNode llies docEmpty]) - docParenR) + , ( hasComments + , docPar + (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + ) ] (ieDsH:ieDsT) -> docAltFilter -- 2.30.2 From 98c93f0d63ed24d67ab28ec6518769494c1b97f2 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 16:35:39 +0100 Subject: [PATCH 077/478] Move expanded binding list to standard indent level for compact layout --- src-literatetests/10-tests.blt | 16 +++ src-literatetests/tests-context-free.blt | 112 ++++++++++-------- .../Brittany/Internal/Layouters/Import.hs | 10 +- 3 files changed, 87 insertions(+), 51 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 95d8593..680d6f1 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -676,6 +676,22 @@ import Data.List ( nub , indexElem ) +#test a-ridiculous-amount-of-elements +import Test ( Long + , list + , with + , items + , that + , will + , not + , quite + , fit + , onA + , single + , line + , anymore + ) + #test with-things import Test ( T , T2() diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 6e8c523..f4c4d6d 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -707,6 +707,23 @@ import Data.List (nub) #test several-elements import Data.List (nub, foldl', indexElem) +#test a-ridiculous-amount-of-elements +import Test + ( Long + , list + , with + , items + , that + , will + , not + , quite + , fit + , onA + , single + , line + , anymore + ) + #test with-things import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) @@ -721,15 +738,8 @@ import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T import TestJustShortEnoughModuleNameLike hiding () import TestJustAbitToLongModuleNameLikeTh hiding () -import MoreThanSufficientlyLongModuleNameWithSome ( items - , that - , will - , not - , fit - , inA - , compact - , layout - ) +import MoreThanSufficientlyLongModuleNameWithSome + (items, that, will, not, fit, inA, compact, layout) #test import-with-comments -- Test @@ -739,62 +749,70 @@ import qualified Data.List as L (foldl') {- Test -} #test import-with-comments-2 -import Test ( abc - , def - -- comment - ) +import Test + ( abc + , def + -- comment + ) #test import-with-comments-3 -import Test ( abc - -- comment - ) +import Test + ( abc + -- comment + ) #test import-with-comments-4 -import Test ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) +import Test + ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) -- Test import Test (test) #test import-with-comments-5 -import Test ( -- comment - ) +import Test + ( -- comment + ) #test long-bindings import Test (longbindingNameThatoverflowsColum) import Test (Long(List, Of, Things)) #test things-with-with-comments -import Test ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) - ) -import Test ( Thing( Item - -- and Comment - ) - ) -import Test ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) - ) +import Test + ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +import Test + ( Thing( Item + -- and Comment + ) + ) +import Test + ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) #test prefer-dense-empty-list -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine () +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + () #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 97284a8..5fa05a2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -47,9 +47,6 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - -- NB we don't need to worry about sharing in the below code - -- (docSharedWrapper etc.) because we do not use any docAlt nodes; all - -- "decisions" are made statically. let compact = indentPolicy == IndentPolicyLeft modNameT = Text.pack $ moduleNameString modName @@ -116,7 +113,12 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of if compact then let asDoc = maybe docEmpty makeAsDoc masT - in docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + in docAlt + [ docForceSingleline $ + docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + , docAddBaseY BrIndentRegular $ + docPar (docSeq [importHead, asDoc]) bindingsD + ] else case masT of Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] -- 2.30.2 From 0f3ee76944d041c5c36bff828f5e1553d4e198cd Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Dec 2017 23:26:18 +0100 Subject: [PATCH 078/478] Fix shebang handling with stdin input Fixes #92 probably should update upstream (ghc-exactprint) --- brittany.cabal | 2 +- .../Brittany/Internal/ExactPrintUtils.hs | 51 +++++++++++++++++-- .../Haskell/Brittany/Internal/PreludeUtils.hs | 3 ++ 3 files changed, 51 insertions(+), 5 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index bfba1dc..42277ad 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -82,7 +82,7 @@ library { { 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 + , ghc-exactprint >=0.5.3.0 && <0.5.6 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.6 , mtl >=2.2.1 && <2.3 diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index d0f481c..7494d9e 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -24,11 +24,17 @@ import qualified DynFlags as GHC import qualified GHC as GHC hiding (parseModule) import qualified Parser as GHC import qualified SrcLoc as GHC +import qualified FastString as GHC +import qualified GHC as GHC hiding (parseModule) +import qualified Lexer as GHC +import qualified StringBuffer as GHC +import qualified Outputable as GHC import RdrName ( RdrName(..) ) import HsSyn import SrcLoc ( SrcSpan, Located ) import RdrName ( RdrName(..) ) + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint @@ -106,10 +112,47 @@ parseModuleFromString args fp dynCheck str = $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s) - x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 - either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) - (\(a, m) -> pure (a, m, x)) - $ ExactPrint.parseWith dflags1 fp GHC.parseModule str + dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 + let res = parseModulePure dflags1 fp str + case res of + Left (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err + Right (a , m ) -> pure (a, m, dynCheckRes) + +----------- + +-- this function should move to ghc-exactprint. btw, we can deprecate/remove +-- the `parseModuleFromString` function that I added initially to +-- ghc-exactprint. +parseModulePure + :: GHC.DynFlags + -> System.IO.FilePath + -> String + -> Either (SrcSpan, String) (ExactPrint.Anns, GHC.ParsedSource) +parseModulePure dflags fileName str = + let (str1, lp) = ExactPrint.stripLinePragmas str + res = case runParser GHC.parseModule dflags fileName str1 of + GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) + GHC.POk x pmod -> Right $ (mkApiAnns x, lp, dflags, pmod) + in ExactPrint.postParseTransform res ExactPrint.normalLayout + +-- copied from exactprint until exactprint exposes a proper interface. +runParser + :: GHC.P a + -> GHC.DynFlags + -> System.IO.FilePath + -> String + -> GHC.ParseResult a +runParser parser flags filename str = GHC.unP parser parseState + where + location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 + buffer = GHC.stringToStringBuffer str + parseState = GHC.mkPState flags buffer location +mkApiAnns :: GHC.PState -> GHC.ApiAnns +mkApiAnns pstate = + ( Map.fromListWith (++) . GHC.annotations $ pstate + , Map.fromList + ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate) + ) ----------- diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs index d34690c..88f2894 100644 --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -46,6 +46,9 @@ traceFunctionWith name s1 s2 f x = putStrErrLn :: String -> IO () putStrErrLn s = hPutStrLn stderr s +putStrErr :: String -> IO () +putStrErr s = hPutStr stderr s + printErr :: Show a => a -> IO () printErr = putStrErrLn . show -- 2.30.2 From 292bd3d216f679613c33b8a0d568af95c9f01f75 Mon Sep 17 00:00:00 2001 From: Tuncer Ayaz Date: Sat, 23 Dec 2017 00:12:51 +0000 Subject: [PATCH 079/478] stack.yaml: update to lts-10.0 --- stack.yaml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/stack.yaml b/stack.yaml index 539cd6d..74e27d2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,11 +1,4 @@ -resolver: lts-9.0 - -extra-deps: - - monad-memo-0.4.1 - - czipwith-1.0.0.0 - - butcher-1.2.0.0 - - data-tree-print-0.1.0.0 - - deque-0.2 +resolver: lts-10.0 packages: - . -- 2.30.2 From 8137035ac2e6144200bec6903489904350fa5a44 Mon Sep 17 00:00:00 2001 From: Tuncer Ayaz Date: Sat, 23 Dec 2017 01:59:49 +0000 Subject: [PATCH 080/478] Resurrect old stack.yaml for lts-9.0 ci job --- .travis.yml | 2 +- stack-lts-9.0.yaml | 11 +++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) create mode 100644 stack-lts-9.0.yaml diff --git a/.travis.yml b/.travis.yml index e1c64bf..6577274 100644 --- a/.travis.yml +++ b/.travis.yml @@ -115,7 +115,7 @@ matrix: #- env: BUILD=stack ARGS="--resolver lts-7" # compiler: ": #stack 8.0.1" # addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-8" + - env: BUILD=stack ARGS="--stack-yaml stack-lts-9.0.yaml" compiler: ": #stack 8.0.2" addons: {apt: {packages: [libgmp-dev]}} diff --git a/stack-lts-9.0.yaml b/stack-lts-9.0.yaml new file mode 100644 index 0000000..539cd6d --- /dev/null +++ b/stack-lts-9.0.yaml @@ -0,0 +1,11 @@ +resolver: lts-9.0 + +extra-deps: + - monad-memo-0.4.1 + - czipwith-1.0.0.0 + - butcher-1.2.0.0 + - data-tree-print-0.1.0.0 + - deque-0.2 + +packages: + - . -- 2.30.2 From ac9d505334204de5e0833c045b83c29868ccc2c5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 28 Dec 2017 17:30:26 +0100 Subject: [PATCH 081/478] Rename the ghc-8.0.2 stack yaml --- .travis.yml | 2 +- stack-lts-9.0.yaml => stack-8.0.2.yaml | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename stack-lts-9.0.yaml => stack-8.0.2.yaml (100%) diff --git a/.travis.yml b/.travis.yml index 6577274..50a0a71 100644 --- a/.travis.yml +++ b/.travis.yml @@ -115,7 +115,7 @@ matrix: #- env: BUILD=stack ARGS="--resolver lts-7" # compiler: ": #stack 8.0.1" # addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--stack-yaml stack-lts-9.0.yaml" + - env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml" compiler: ": #stack 8.0.2" addons: {apt: {packages: [libgmp-dev]}} diff --git a/stack-lts-9.0.yaml b/stack-8.0.2.yaml similarity index 100% rename from stack-lts-9.0.yaml rename to stack-8.0.2.yaml -- 2.30.2 From 43abab2dd2c87c7e9547e2e2b43270dde0da178e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 28 Dec 2017 20:46:03 +0100 Subject: [PATCH 082/478] Remove space after opening parenthesis (fixes #87) --- src-literatetests/15-regressions.blt | 2 +- src-literatetests/tests-context-free.blt | 4 ++-- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index c2290ba..0fbc830 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -219,7 +219,7 @@ showPackageDetailedInfo pkginfo = , entry "Versions installed" installedVersions - ( altText + (altText null (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 7700adb..0918e60 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -714,7 +714,7 @@ func #test some indentation thingy func = - ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj $ abc $ def $ ghi @@ -840,7 +840,7 @@ showPackageDetailedInfo pkginfo = , entry "Versions installed" installedVersions - ( altText + (altText null (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 2eb1863..1462c56 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -327,7 +327,7 @@ layoutExpr lexpr@(L _ expr) = do ] , docSetBaseY $ docLines [ docCols ColOpPrefix - [ docParenLSep + [ docLit $ Text.pack "(" , docAddBaseY (BrIndentSpecial 2) innerExpDoc ] , docLit $ Text.pack ")" -- 2.30.2 From 37e355fea57133302f0fc4b27cc358b5b3745466 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 28 Dec 2017 21:38:31 +0100 Subject: [PATCH 083/478] Support hanging type signature config option --- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/Config.hs | 2 + .../Haskell/Brittany/Internal/Config/Types.hs | 11 +++++ .../Brittany/Internal/Layouters/Decl.hs | 48 ++++++++++++------- 5 files changed, 47 insertions(+), 16 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 938aca6..5567e68 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -173,6 +173,7 @@ defaultTestConfig = Config , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 30eac3e..1ee5203 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -55,6 +55,7 @@ defaultTestConfig = Config , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index baaca1f..f225545 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -63,6 +63,7 @@ staticDefaultConfig = Config , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -156,6 +157,7 @@ configParser = do , _lconfig_columnAlignMode = mempty , _lconfig_alignmentLimit = mempty , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index d726d8a..f2530b0 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -73,6 +73,17 @@ data CLayoutConfig f = LayoutConfig -- short <- some more stuff -- that requires two lines -- loooooooong <- stuff + , _lconfig_hangingTypeSignature :: f (Last Bool) + -- Do not put "::" in a new line, and use hanging indentation for the + -- signature, i.e.: + -- func :: SomeLongStuff + -- -> SomeLongStuff + -- instead of the usual + -- func + -- :: SomeLongStuff + -- -> SomeLongStuff + -- As usual for hanging indentation, the result will be + -- context-sensitive (in the function name). } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 30e26c2..8724291 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -52,23 +52,39 @@ layoutSig lsig@(L _loc sig) = case sig of let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - docAlt - $ [ docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr - , appSep $ docLit $ Text.pack "::" - , docForceSingleline typeDoc - ] - | not hasComments - ] - ++ [ docAddBaseY BrIndentRegular $ docPar - (docWrapNodeRest lsig $ docLit nameStr) - ( docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc + shouldBeHanging <- mAsk + <&> _conf_layout + .> _lconfig_hangingTypeSignature + .> confUnpack + if shouldBeHanging + then docSeq + [ appSep $ docWrapNodeRest lsig $ docLit nameStr + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ] + ] + else + docAlt + $ [ docSeq + [ appSep $ docWrapNodeRest lsig $ docLit nameStr + , appSep $ docLit $ Text.pack "::" + , docForceSingleline typeDoc + ] + | not hasComments + ] + ++ [ docAddBaseY BrIndentRegular $ docPar + (docWrapNodeRest lsig $ docLit nameStr) + ( docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ) ] - ) - ] InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name -- 2.30.2 From f1b49b082fec2e4ca1c2dc4de7773546daf13763 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 31 Dec 2017 00:04:53 -0500 Subject: [PATCH 084/478] Format let and in on a single line if they fit The following is wasteful of vertical space: ``` _ = let longIdentifierForShortValue = 1 in longIdentifierForShortValue + longIdentifierForShortValue ``` We should format it on two lines if possible. ``` _ = let longIdentifierForShortValue = 1 in longIdentifierForShortValue + longIdentifierForShortValue ``` This commit also allows for a mix of variations: ``` _ = let longIdentifierForShortValue = 1 in longIdentifierForShortValue + longIdentifierForShortValue _ = let longIdentifierForShortValue = 1 in longIdentifierForShortValue + longIdentifierForShortValue ``` --- src-literatetests/tests-context-free.blt | 5 ++ .../Brittany/Internal/Layouters/Expr.hs | 54 +++++++++---------- 2 files changed, 32 insertions(+), 27 deletions(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 0918e60..e8303cd 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -510,6 +510,11 @@ func = (abc, def) func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) +#test let in on single line +foo = + let longIdentifierForShortValue = 1 + in longIdentifierForShortValue + longIdentifierForShortValue + ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 1462c56..6e6929f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -531,6 +531,9 @@ layoutExpr lexpr@(L _ expr) = do HsLet binds exp1 -> do expDoc1 <- docSharedWrapper layoutExpr exp1 mBindDocs <- layoutLocalBinds binds + let + whenIndentLeftOr x y = + if indentPolicy == IndentPolicyLeft then x else y -- this `docSetIndentLevel` might seem out of place, but is here due to -- ghc-exactprint's DP handling of "let" in particular. -- Just pushing another indentation level is a straightforward approach @@ -538,39 +541,36 @@ layoutExpr lexpr@(L _ expr) = do -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. docSetIndentLevel $ case mBindDocs of - Just [bindDoc] -> docAltFilter - [ ( True - , docSeq + Just [bindDoc] -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "let" , appSep $ docForceSingleline $ return bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline $ expDoc1 ] - ) - , ( indentPolicy /= IndentPolicyLeft - , docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ return bindDoc - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 - ] + , docLines + [ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , whenIndentLeftOr docForceSingleline docSetBaseAndIndent + $ return bindDoc + ] + , docAddBaseY BrIndentRegular + $ docPar + (appSep $ docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) + ] + , docAlt + [ docSeq + [ whenIndentLeftOr id appSep $ docLit $ Text.pack "in " + , whenIndentLeftOr docForceSingleline docSetBaseAndIndent expDoc1 + ] + , docAddBaseY BrIndentRegular + $ docPar + (appSep $ docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] ] - ) - , ( True - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (appSep $ docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - , docAddBaseY BrIndentRegular - $ docPar - (appSep $ docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) - ] - ) ] Just bindDocs@(_:_) -> docAltFilter --either -- 2.30.2 From cab12975851076e568c839471ce46830a3948dfc Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 31 Dec 2017 00:11:10 -0500 Subject: [PATCH 085/478] Change function name to if/else --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 6e6929f..fcf69b4 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -532,7 +532,7 @@ layoutExpr lexpr@(L _ expr) = do expDoc1 <- docSharedWrapper layoutExpr exp1 mBindDocs <- layoutLocalBinds binds let - whenIndentLeftOr x y = + ifIndentLeftElse x y = if indentPolicy == IndentPolicyLeft then x else y -- this `docSetIndentLevel` might seem out of place, but is here due to -- ghc-exactprint's DP handling of "let" in particular. @@ -552,7 +552,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" - , whenIndentLeftOr docForceSingleline docSetBaseAndIndent + , ifIndentLeftElse docForceSingleline docSetBaseAndIndent $ return bindDoc ] , docAddBaseY BrIndentRegular @@ -562,8 +562,8 @@ layoutExpr lexpr@(L _ expr) = do ] , docAlt [ docSeq - [ whenIndentLeftOr id appSep $ docLit $ Text.pack "in " - , whenIndentLeftOr docForceSingleline docSetBaseAndIndent expDoc1 + [ ifIndentLeftElse id appSep $ docLit $ Text.pack "in " + , ifIndentLeftElse docForceSingleline docSetBaseAndIndent expDoc1 ] , docAddBaseY BrIndentRegular $ docPar -- 2.30.2 From 8fe9ba1f43b753c2522a37aece27e4bd9c523502 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 13 Jan 2018 18:02:00 +0100 Subject: [PATCH 086/478] Update readme: Add editor integration paragraph --- README.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/README.md b/README.md index c7bd461..ba6fe36 100644 --- a/README.md +++ b/README.md @@ -96,6 +96,19 @@ log the size of the input, but _not_ the full requests.) aura -A brittany ~~~~ +# Editor Integration + +#### Sublime text + [In this gist](https://gist.github.com/lspitzner/097c33177248a65e7657f0c6d0d12075) + I have described a haskell setup that includes a shortcut to run brittany formatting. +#### VSCode + [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) + connects commandline `brittany` to VSCode formatting API. Thanks to Max Garbriel. +#### Via HIE + [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) + includes a `brittany` plugin that directly uses the brittany library. + Relevant for any editors that properly support the language-server-protocol. + # Usage - Default mode of operation: Transform a single module, from `stdin` to `stdout`. -- 2.30.2 From 37bc36f10a8924552bb666104bc92f07fc58732a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 13 Jan 2018 18:05:21 +0100 Subject: [PATCH 087/478] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index ba6fe36..3850fbd 100644 --- a/README.md +++ b/README.md @@ -103,7 +103,7 @@ log the size of the input, but _not_ the full requests.) I have described a haskell setup that includes a shortcut to run brittany formatting. #### VSCode [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) - connects commandline `brittany` to VSCode formatting API. Thanks to Max Garbriel. + connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGarbriel. #### Via HIE [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) includes a `brittany` plugin that directly uses the brittany library. -- 2.30.2 From e788ac9afdc7210aecf1e24d698859cf785458b5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 13 Jan 2018 18:31:39 +0100 Subject: [PATCH 088/478] Minor fixup in Main.hs for next butcher release --- src-brittany/Main.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 046c830..56aa928 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -140,16 +140,16 @@ mainCmdParser helpDesc = do "" ["write-mode"] "(display|inplace)" - Flag - { _flag_help = Just $ PP.vcat + ( flagHelp + ( PP.vcat [ PP.text "display: output for any input(s) goes to stdout" , PP.text "inplace: override respective input file (without backup!)" ] - , _flag_default = Just Display - } + ) + <> flagDefault Display + ) inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") reorderStop - desc <- peekCmdDesc addCmdImpl $ void $ do when printLicense $ do print licenseDoc @@ -161,7 +161,7 @@ mainCmdParser helpDesc = do putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do - liftIO $ print $ ppHelpShallow desc + liftIO $ print $ ppHelpShallow helpDesc System.Exit.exitSuccess let inputPaths = if null inputParams then [Nothing] else map Just inputParams -- 2.30.2 From 399e2f4f43a4fad1ddf68da6f065d0d16ea08991 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 13 Jan 2018 18:41:51 +0100 Subject: [PATCH 089/478] Minor cleanups --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index fcf69b4..8d90148 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -532,6 +532,7 @@ layoutExpr lexpr@(L _ expr) = do expDoc1 <- docSharedWrapper layoutExpr exp1 mBindDocs <- layoutLocalBinds binds let + ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = if indentPolicy == IndentPolicyLeft then x else y -- this `docSetIndentLevel` might seem out of place, but is here due to @@ -557,17 +558,17 @@ layoutExpr lexpr@(L _ expr) = do ] , docAddBaseY BrIndentRegular $ docPar - (appSep $ docLit $ Text.pack "let") + (docLit $ Text.pack "let") (docSetBaseAndIndent $ return bindDoc) ] , docAlt [ docSeq - [ ifIndentLeftElse id appSep $ docLit $ Text.pack "in " + [ appSep $ docLit $ Text.pack $ ifIndentLeftElse "in" "in " , ifIndentLeftElse docForceSingleline docSetBaseAndIndent expDoc1 ] , docAddBaseY BrIndentRegular $ docPar - (appSep $ docLit $ Text.pack "in") + (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) ] ] -- 2.30.2 From b46f9dd23b29f71a34896a6e52d0f3ce855414eb Mon Sep 17 00:00:00 2001 From: Erik Schnetter Date: Mon, 15 Jan 2018 18:11:50 -0500 Subject: [PATCH 090/478] Correct wording of warning message "certain" -> "some" --- src-brittany/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 56aa928..bcb8a3f 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -281,7 +281,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx putErrorLn $ "Error: detected unprocessed comments." ++ " The transformation output will most likely" - ++ " not contain certain of the comments" + ++ " not contain some of the comments" ++ " present in the input haskell source file." putErrorLn $ "Affected are the following comments:" unused `forM_` \case -- 2.30.2 From d086140120dc1398d8149723979c1e347bdc7130 Mon Sep 17 00:00:00 2001 From: Jake Zimmerman Date: Wed, 24 Jan 2018 15:19:04 -0800 Subject: [PATCH 091/478] Add Vim / Neovim plugin I saw that you started an editor integration section, and thought that it might benefit from a Vim / Neovim section \o/ Thanks for this program by the way! --- README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/README.md b/README.md index 3850fbd..cc264e4 100644 --- a/README.md +++ b/README.md @@ -108,6 +108,9 @@ log the size of the input, but _not_ the full requests.) [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) includes a `brittany` plugin that directly uses the brittany library. Relevant for any editors that properly support the language-server-protocol. +#### Neovim / Vim 8 + The [Neoformat](https://github.com/sbdchd/neoformat) plugin comes with support for + brittany built in. # Usage -- 2.30.2 From 18b3cfaf88d44ba6d2e1bfc27a3d43eb8381314b Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Mon, 15 Jan 2018 16:02:14 -0500 Subject: [PATCH 092/478] Fix infix constructor pattern matching for normal constructors Brittany was previously only support symbol based infix constructors. It is common in some libraries (for example Esqueleto) to pattern match on normal constructors as infix. Brittany was failing in this case by not wrapping the constructor name in back ticks/spaces. Backticks and spaces have been added in the case where the constructor contains any alpha characters. --- src-literatetests/10-tests.blt | 3 +++ src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 5 ++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index a3d8591..6659847 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -355,6 +355,9 @@ func (x:xr) = x #pending func (x:+:xr) = x +#test normal infix constructor +func (x `Foo` xr) = x + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index ebdd91d..2f881a0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -13,6 +13,7 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics +import Data.Char (isAlpha) import RdrName ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import HsSyn @@ -80,7 +81,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of let nameDoc = lrdrNameToText lname leftDoc <- colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right - middle <- docLit nameDoc + middle <- docLit $ if Text.any isAlpha nameDoc + then Text.pack " `" <> nameDoc <> Text.pack "` " + else nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr -- 2.30.2 From 019d47bf7e7a4c4d7cca18b41f9319c6f518ff6e Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Mon, 15 Jan 2018 19:11:25 -0500 Subject: [PATCH 093/478] Change infix patterns to include spaces This commit changes infix patterns to utilize `lrdrNameToTextAnn`. This function allows the logic to avoid introspecting on the constructor name. Additionally this adds spaces to all infix operator pattern matches. Previously infix symbols did not include spaces: ``` foo (x:xs) = _ ``` Now they include a space ``` foo (x : xs) = _ ``` --- src-literatetests/10-tests.blt | 4 ++-- src-literatetests/15-regressions.blt | 4 ++-- src-literatetests/tests-context-free.blt | 6 +++--- .../Haskell/Brittany/Internal/Layouters/Pattern.hs | 8 +++----- 4 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6659847..af873df 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -349,11 +349,11 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable func (A a) = a #test list constructor -func (x:xr) = x +func (x : xr) = x #test some other constructor symbol #pending -func (x:+:xr) = x +func (x :+: xr) = x #test normal infix constructor func (x `Foo` xr) = x diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0fbc830..5c31ab6 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -123,8 +123,8 @@ func = do #test list comprehension comment placement func = [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_:_)) <- nosuchFooThing - , gast <- award + | (thing, _got, alts@(_ : _)) <- nosuchFooThing + , gast <- award ] #test if-then-else comment placement diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index e8303cd..0d3d8cf 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -366,11 +366,11 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable func (A a) = a #test list constructor -func (x:xr) = x +func (x : xr) = x #test some other constructor symbol #pending -func (x:+:xr) = x +func (x :+: xr) = x ############################################################################### @@ -748,7 +748,7 @@ func = do #test list comprehension comment placement func = [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_:_)) <- nosuchFooThing + | (thing, _got, alts@(_ : _)) <- nosuchFooThing , gast <- award ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 2f881a0..317fbe2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -78,12 +78,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of return $ x1 Seq.<| xR ConPatIn lname (InfixCon left right) -> do -- a :< b -> expr - let nameDoc = lrdrNameToText lname - leftDoc <- colsWrapPat =<< layoutPat left + let nameDoc = lrdrNameToTextAnn lname + leftDoc <- appSep . colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right - middle <- docLit $ if Text.any isAlpha nameDoc - then Text.pack " `" <> nameDoc <> Text.pack "` " - else nameDoc + middle <- appSep . docLit =<< nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr -- 2.30.2 From eb8f0de6c3b04505f2350137ce41308c25149c54 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Mon, 15 Jan 2018 19:15:51 -0500 Subject: [PATCH 094/478] Remove redundant import. --- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 317fbe2..c04790d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -13,7 +13,6 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import Data.Char (isAlpha) import RdrName ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import HsSyn -- 2.30.2 From 077b93db016123ba58aed9568fef05bfeb0dd7f8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 9 Feb 2018 16:50:57 +0100 Subject: [PATCH 095/478] Minor refactor --- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index c04790d..51bb03a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -77,10 +77,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of return $ x1 Seq.<| xR ConPatIn lname (InfixCon left right) -> do -- a :< b -> expr - let nameDoc = lrdrNameToTextAnn lname - leftDoc <- appSep . colsWrapPat =<< layoutPat left + nameDoc <- lrdrNameToTextAnn lname + leftDoc <- appSep . colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right - middle <- appSep . docLit =<< nameDoc + middle <- appSep $ docLit nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr -- 2.30.2 From 8430b74b1ad77835f755a821bd32635879bc13f5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 20:05:48 +0100 Subject: [PATCH 096/478] Switch to butcher-1.3, Improve help layout, fixes #103 --- brittany.cabal | 2 +- src-brittany/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 42277ad..ae71fde 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -94,7 +94,7 @@ library { , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4 - , butcher >=1.2 && <1.3 + , butcher >=1.3 && <1.4 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 , extra >=1.4.10 && <1.7 diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index bcb8a3f..cc721d2 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -161,7 +161,7 @@ mainCmdParser helpDesc = do putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do - liftIO $ print $ ppHelpShallow helpDesc + liftIO $ putStrLn $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } $ ppHelpShallow helpDesc System.Exit.exitSuccess let inputPaths = if null inputParams then [Nothing] else map Just inputParams -- 2.30.2 From d749c0da2715f0d0678644ab95429a8715827a50 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 20:06:31 +0100 Subject: [PATCH 097/478] Prevent crash if ~/.config does not exist (fixes #115) --- src-brittany/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index cc721d2..324a7a3 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -346,7 +346,7 @@ readConfigs cmdlineConfig configPaths = do userConfigXdg <- readConfig userConfigPathXdg let userConfig = userConfigSimple <|> userConfigXdg when (Data.Maybe.isNothing userConfig) $ do - liftIO $ Directory.createDirectoryIfMissing False userBritPathXdg + liftIO $ Directory.createDirectoryIfMissing True userBritPathXdg writeDefaultConfig userConfigPathXdg -- rightmost has highest priority pure $ [userConfig, localConfig] -- 2.30.2 From 779a23c380d1ff3bc68642d91a367903d05aa6bd Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 20:32:19 +0100 Subject: [PATCH 098/478] Update README.md: Conf file discovery description --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index cc264e4..8366d6b 100644 --- a/README.md +++ b/README.md @@ -56,7 +56,8 @@ log the size of the input, but _not_ the full requests.) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. - uses/creates user config file in `~/.config/brittany/config.yaml`; - also reads `brittany.yaml` in current dir if present. + also reads (the first) `brittany.yaml` found in current or parent + directories. # Installation -- 2.30.2 From 91de1ca08cc7e95c072a85fd98d11926ba4c0689 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 23:48:00 +0100 Subject: [PATCH 099/478] Fix bang deletion on ghc-8.2, Add testcase (fixes #116) --- src-literatetests/15-regressions.blt | 6 ++++ .../Brittany/Internal/Layouters/Decl.hs | 31 ++++++++++++++++--- 2 files changed, 33 insertions(+), 4 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 5c31ab6..dda42a0 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -513,3 +513,9 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] #test issue 70 {-# LANGUAGE TemplateHaskell #-} deriveFromJSON (unPrefix "assignPost") ''AssignmentPost + +#test issue 116 +{-# LANGUAGE BangPatterns #-} +func = do + let !forced = some + pure () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 8724291..c6ff4e0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -192,16 +192,17 @@ layoutPatternBind -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered -layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do +layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match - patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of - (Just idStr, p1:pr) | isInfix -> docCols + let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr + patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of + (Just idStr, p1 : pr) | isInfix -> docCols ColPatternsFuncInfix ( [appSep $ docForceSingleline p1, appSep $ docLit idStr] ++ (spacifyDocs $ docForceSingleline <$> pr) ) - (Just idStr, [] ) -> docLit idStr + (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix $ appSep (docLit $ idStr) @@ -220,6 +221,28 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs mWhereDocs hasComments +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +fixPatternBindIdentifier + :: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text +fixPatternBindIdentifier ctx idStr = case ctx of + (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr + (FunRhs _ _ NoSrcStrict) -> idStr + (StmtCtxt ctx1 ) -> fixPatternBindIdentifier' ctx1 + _ -> idStr + where + -- I have really no idea if this path ever occurs, but better safe than + -- risking another "drop bangpatterns" bugs. + fixPatternBindIdentifier' = \case + (PatGuard ctx1) -> fixPatternBindIdentifier ctx1 idStr + (ParStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 + (TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 + _ -> idStr +#else /* ghc-8.0 */ +fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text +fixPatternBindIdentifier _ x = x +#endif + layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -- 2.30.2 From 55b1c71bf3da03eab9a722d7143871fe079c4f9d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 01:00:01 +0100 Subject: [PATCH 100/478] Fix a layouting mistake that went unnoticed so far --- src-literatetests/15-regressions.blt | 6 ++++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 7 +++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index dda42a0..7654285 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -519,3 +519,9 @@ deriveFromJSON (unPrefix "assignPost") ''AssignmentPost func = do let !forced = some pure () + +#test let-in-hanging +spanKey p q = case minViewWithKey q of + Just ((k, _), q') | p k -> + let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') + _ -> ([], q) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index c6ff4e0..9681453 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -300,10 +300,13 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] let singleLineGuardsDoc guards = appSep $ case guards of [] -> docEmpty - [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] + [g] -> docSeq + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) + ++ (List.intersperse docCommaSep + (docForceSingleline . return <$> gs) + ) indentPolicy <- mAsk <&> _conf_layout -- 2.30.2 From 81928ea59715508d6d2b931bbed82f205fa9ac7d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 01:14:24 +0100 Subject: [PATCH 101/478] Switch to ghc-exactprint-0.5.6.0, Remove code duplication --- brittany.cabal | 2 +- .../Brittany/Internal/ExactPrintUtils.hs | 39 +------------------ 2 files changed, 2 insertions(+), 39 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index ae71fde..d0059f1 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -82,7 +82,7 @@ library { { 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.5.6 + , ghc-exactprint >=0.5.6.0 && <0.5.7 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.6 , mtl >=2.2.1 && <2.3 diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 7494d9e..749804c 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -113,48 +113,11 @@ parseModuleFromString args fp dynCheck str = $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s) dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 - let res = parseModulePure dflags1 fp str + let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of Left (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err Right (a , m ) -> pure (a, m, dynCheckRes) ------------ - --- this function should move to ghc-exactprint. btw, we can deprecate/remove --- the `parseModuleFromString` function that I added initially to --- ghc-exactprint. -parseModulePure - :: GHC.DynFlags - -> System.IO.FilePath - -> String - -> Either (SrcSpan, String) (ExactPrint.Anns, GHC.ParsedSource) -parseModulePure dflags fileName str = - let (str1, lp) = ExactPrint.stripLinePragmas str - res = case runParser GHC.parseModule dflags fileName str1 of - GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) - GHC.POk x pmod -> Right $ (mkApiAnns x, lp, dflags, pmod) - in ExactPrint.postParseTransform res ExactPrint.normalLayout - --- copied from exactprint until exactprint exposes a proper interface. -runParser - :: GHC.P a - -> GHC.DynFlags - -> System.IO.FilePath - -> String - -> GHC.ParseResult a -runParser parser flags filename str = GHC.unP parser parseState - where - location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 - buffer = GHC.stringToStringBuffer str - parseState = GHC.mkPState flags buffer location -mkApiAnns :: GHC.PState -> GHC.ApiAnns -mkApiAnns pstate = - ( Map.fromListWith (++) . GHC.annotations $ pstate - , Map.fromList - ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate) - ) - ------------ commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob ast = do -- 2.30.2 From c28ec4cfdfe33e222a76053bb49dbee87c476382 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 14:42:26 +0100 Subject: [PATCH 102/478] Bump butcher version in stack-8.0.2.yaml --- stack-8.0.2.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index 539cd6d..51c6004 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,7 +3,7 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.0.0 - - butcher-1.2.0.0 + - butcher-1.3.0.0 - data-tree-print-0.1.0.0 - deque-0.2 -- 2.30.2 From c28636adca522713ceebf51854162dd11f548828 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 15:20:22 +0100 Subject: [PATCH 103/478] Add ghc-exactprint-0.5.6.0 to extra-deps in stack.yaml --- stack-8.0.2.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index 51c6004..ca6ad6a 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -6,6 +6,7 @@ extra-deps: - butcher-1.3.0.0 - data-tree-print-0.1.0.0 - deque-0.2 + - ghc-exactprint-0.5.6.0 packages: - . -- 2.30.2 From f17d9f8bf6f71358d3b9aa287150a923de38b1c5 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Wed, 14 Feb 2018 06:54:39 -0800 Subject: [PATCH 104/478] Fix spelling of my name --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 8366d6b..2f55f03 100644 --- a/README.md +++ b/README.md @@ -104,7 +104,7 @@ log the size of the input, but _not_ the full requests.) I have described a haskell setup that includes a shortcut to run brittany formatting. #### VSCode [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) - connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGarbriel. + connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGabriel. #### Via HIE [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) includes a `brittany` plugin that directly uses the brittany library. -- 2.30.2 From 4b53072ccdfa348d107044c624afaf4a1e973544 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 17:18:15 +0100 Subject: [PATCH 105/478] Correct some commandline help output --- src-brittany/Main.hs | 9 +++++---- src/Language/Haskell/Brittany/Internal/Config.hs | 6 +++--- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 324a7a3..f986ad9 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -82,9 +82,10 @@ helpDoc = PP.vcat $ List.intersperse ] , parDocW [ "This program is written carefully and contains safeguards to ensure" - , "the transformation does not change semantics (or the syntax tree at all)" - , "and that no comments are removed." - , "Nonetheless, this is a young project, and there will always be bugs." + , "the output is syntactically valid and that no comments are removed." + , "Nonetheless, this is a young project, and there will always be bugs," + , "and ensuring that the transformation never changes semantics of the" + , "transformed source is currently not possible." , "Please do check the output and do not let brittany override your large" , "codebase without having backups." ] @@ -148,7 +149,7 @@ mainCmdParser helpDesc = do ) <> flagDefault Display ) - inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") + inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files") reorderStop addCmdImpl $ void $ do when printLicense $ do diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index f225545..ad991b5 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -105,7 +105,7 @@ configParser = do cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") @@ -119,9 +119,9 @@ configParser = do dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") -- 2.30.2 From bac69ba54f3988f4f2999366a038c973bedb8a11 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 17:18:22 +0100 Subject: [PATCH 106/478] Bump to 0.9.0.1, Add changelog --- ChangeLog.md | 16 ++++++++++++++++ brittany.cabal | 2 +- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 05a7ea2..1b23e1e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # Revision history for brittany +## 0.9.0.1 -- February 2018 + +* Support `TupleSections` (thanks to Matthew Piziak) +* Bugfixes: + - Fix Shebang handling with stdin input (#92) + - Fix bug that effectively deleted strict/lazy matches (BangPatterns) (#116) + - Fix infix operator whitespace bug (#101, #114) + - Fix help command output and its layouting (#103) + - Fix crash when config dir does not exist yet (#115) +* Layouting changes: + - no space after opening non-tuple parenthesis even for multi-line case + - use spaces around infix operators (applies to sections and in pattern + matches) + - Let-in is layouted more flexibly in fewer lines, if possible + (thanks to Evan Borden) + ## 0.9.0.0 -- December 2017 * Change default global config path (use XDG spec) diff --git a/brittany.cabal b/brittany.cabal index d0059f1..b6ecf52 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.9.0.0 +version: 0.9.0.1 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From c124336738b922b0269d4e44e1c1095ada9ec8e9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 19 Feb 2018 17:17:39 +0100 Subject: [PATCH 107/478] Fix NOINLINE pragma layouting --- src-literatetests/10-tests.blt | 4 ++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index af873df..3f7ec68 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -287,6 +287,10 @@ func = f {-# INLINE CONLIKE [1] f #-} f = id +#test noinline pragma 1 +{-# NOINLINE func #-} +func :: Int + #test inline pragma 4 #pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2. func = f diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 9681453..400d422 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -94,7 +94,8 @@ layoutSig lsig@(L _loc sig) = case sig of NoInline -> "NOINLINE " EmptyInlineSpec -> "" -- i have no idea if this is correct. let phaseStr = case phaseAct of - NeverActive -> "[] " + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default AlwaysActive -> "" ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] " -- 2.30.2 From 19e31fdaf2bed40e25f9c9b29907441279f53fbe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 19 Feb 2018 21:33:43 +0100 Subject: [PATCH 108/478] Improve layouting of RecordUpd, Fix minor issue for HsLet --- src-literatetests/15-regressions.blt | 5 +- .../Brittany/Internal/Layouters/Expr.hs | 55 ++++++++++++++----- 2 files changed, 42 insertions(+), 18 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 7654285..5e4f52c 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -367,9 +367,8 @@ runBrittany tabSize text = do let config' = staticDefaultConfig config = config' - { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce - tabSize - } + { _conf_layout = + (_conf_layout config') { _lconfig_indentAmount = coerce tabSize } , _conf_forward = forwardOptionsSyntaxExtsEnabled } parsePrintModule config text diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 8d90148..807aad8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -535,13 +535,15 @@ layoutExpr lexpr@(L _ expr) = do ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = if indentPolicy == IndentPolicyLeft then x else y - -- this `docSetIndentLevel` might seem out of place, but is here due to - -- ghc-exactprint's DP handling of "let" in particular. + -- this `docSetBaseAndIndent` might seem out of place (especially the + -- Indent part; setBase is necessary due to the use of docLines below), + -- but is here due to ghc-exactprint's DP handling of "let" in + -- particular. -- Just pushing another indentation level is a straightforward approach -- to making brittany idempotent, even though the result is non-optimal -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. - docSetIndentLevel $ case mBindDocs of + docSetBaseAndIndent $ case mBindDocs of Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" @@ -733,6 +735,8 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do + -- TODO: the layouter for RecordUpd is slightly more clever. Should + -- probably copy the approach from there. let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do fExpDoc <- if pun @@ -852,7 +856,7 @@ layoutExpr lexpr@(L _ expr) = do Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) docAltFilter - -- singleline + -- container { fieldA = blub, fieldB = blub } [ ( True , docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc @@ -870,7 +874,10 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] ) - -- wild-indentation block + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } , ( indentPolicy /= IndentPolicyLeft , docSeq [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc @@ -881,7 +888,7 @@ layoutExpr lexpr@(L _ expr) = do , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline $ x + , docForceSingleline x ] Nothing -> docEmpty ] @@ -901,36 +908,54 @@ layoutExpr lexpr@(L _ expr) = do in [line1] ++ lineR ++ [lineN] ] ) - -- strict indentation block + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } , ( True , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docNodeAnnKW lexpr Nothing $ rExprDoc) (docNonBottomSpacing $ docLines $ let + expressionWrapper = if indentPolicy == IndentPolicyLeft + then docForceParSpacing + else docSetBaseY line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n , docWrapNodeRest rF1f $ case rF1e of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular $ x - ] + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] Nothing -> docEmpty ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRecUpdate [ docCommaSep , appSep $ docLit $ fText , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular x - ] + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] Nothing -> docEmpty ] lineN = docSeq [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - in [line1] ++ lineR ++ [lineN]) + in [line1] ++ lineR ++ [lineN] + ) ) ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ -- 2.30.2 From e4dea8783901d44fe5236ef080814fa76250b2e4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Mar 2018 19:11:10 +0100 Subject: [PATCH 109/478] Switch to using branches master/release instead of dev/master --- README.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/README.md b/README.md index 2f55f03..42e7fa5 100644 --- a/README.md +++ b/README.md @@ -160,8 +160,6 @@ a good amount of high-level documentation at [the documentation index](doc/implementation/index.md) -Note that most development happens on the `dev` branch of this repository! - # License Copyright (C) 2016-2017 Lennart Spitzner -- 2.30.2 From 83b39de3d424dc1062b52657109862160fa08c6b Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 23 Feb 2018 21:57:50 +1100 Subject: [PATCH 110/478] Expose readConfigs --- brittany.cabal | 1 + src-brittany/Main.hs | 49 +++------------- src/Language/Haskell/Brittany.hs | 4 ++ .../Haskell/Brittany/Internal/Config.hs | 57 ++++++++++++++++++- stack.yaml | 5 +- 5 files changed, 70 insertions(+), 46 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index b6ecf52..a090280 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -108,6 +108,7 @@ library { , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.3 + , filepath >=1.4.1.0 && <1.5 } default-extensions: { CPP diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index f986ad9..057ad24 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -158,7 +158,7 @@ mainCmdParser helpDesc = do when printVersion $ do do putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner" + putStrLn $ "Copyright (C) 2016-2018 Lennart Spitzner" putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do @@ -170,10 +170,14 @@ mainCmdParser helpDesc = do Display -> repeat Nothing Inplace -> inputPaths - config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case + configsToLoad <- liftIO $ if null configPaths + then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x - when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do + when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ trace (showConfigYaml config) $ return () results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths @@ -317,42 +321,3 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx ] then trace "----" else id - - -readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config -readConfigs cmdlineConfig configPaths = do - userBritPathSimple <- liftIO $ Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- liftIO - $ Directory.getXdgDirectory Directory.XdgConfig "brittany" - let userConfigPathSimple = userBritPathSimple FilePath. "config.yaml" - let userConfigPathXdg = userBritPathXdg FilePath. "config.yaml" - let - findLocalConfig :: MaybeT IO (Maybe (CConfig Option)) - findLocalConfig = do - cwd <- liftIO $ Directory.getCurrentDirectory - let dirParts = FilePath.splitDirectories cwd - let searchDirs = - [ FilePath.joinPath x | x <- reverse $ List.inits dirParts ] - -- when cwd is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] - mFilePath <- liftIO $ Directory.findFileWith Directory.doesFileExist - searchDirs - "brittany.yaml" - case mFilePath of - Nothing -> pure Nothing - Just fp -> readConfig fp - configsRead <- case configPaths of - [] -> do - localConfig <- findLocalConfig - userConfigSimple <- readConfig userConfigPathSimple - userConfigXdg <- readConfig userConfigPathXdg - let userConfig = userConfigSimple <|> userConfigXdg - when (Data.Maybe.isNothing userConfig) $ do - liftIO $ Directory.createDirectoryIfMissing True userBritPathXdg - writeDefaultConfig userConfigPathXdg - -- rightmost has highest priority - pure $ [userConfig, localConfig] - paths -> readConfig `mapM` reverse paths - -- reverse to give highest priority to the first - merged <- - pure $ Semigroup.mconcat $ catMaybes $ configsRead ++ [Just cmdlineConfig] - return $ cZipWith fromOptionIdentity staticDefaultConfig merged diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 5f9a128..9d45dde 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -4,6 +4,10 @@ module Language.Haskell.Brittany ( parsePrintModule , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , Config , CConfig(..) , CDebugConfig(..) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ad991b5..fe1b317 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -9,6 +9,10 @@ module Language.Haskell.Brittany.Internal.Config , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , writeDefaultConfig , showConfigYaml ) @@ -22,8 +26,10 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import qualified Data.Yaml +import Data.CZipWith import UI.Butcher.Monadic +import Data.Monoid ((<>)) import qualified System.Console.CmdArgs.Explicit as CmdArgs @@ -33,7 +39,8 @@ import Language.Haskell.Brittany.Internal.Utils import Data.Coerce ( Coercible, coerce ) - +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath staticDefaultConfig :: Config staticDefaultConfig = Config @@ -189,10 +196,10 @@ configParser = do -- <*> switch (long "barb") -- <*> flag 3 5 (long "barc") -- ) --- +-- -- configParserInfo :: ParserInfo Config -- configParserInfo = ParserInfo --- { infoParser = configParser +-- { infoParser = configParser -- , infoFullDesc = True -- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" -- , infoHeader = return $ PP.text "brittany" @@ -227,6 +234,50 @@ readConfig path = do return $ Just fileConf else return $ Nothing +-- | Returns a global brittany config file +-- If there is no global config in a system, one will be created +userConfigPath :: IO System.IO.FilePath +userConfigPath = do + userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + let searchDirs = [userBritPathSimple, userBritPathXdg] + globalConfig <- Directory.findFileWith Directory.doesFileExist searchDirs "config.yaml" + maybe (writeUserConfig userBritPathXdg) pure globalConfig + where + writeUserConfig dir = do + let createConfPath = dir FilePath. "config.yaml" + liftIO $ Directory.createDirectoryIfMissing True dir + writeDefaultConfig $ createConfPath + pure createConfPath + +-- | Searhes for a local brittany config path starting from a given directory +findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) +findLocalConfigPath dir = do + let dirParts = FilePath.splitDirectories dir + -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] + let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) + Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" + +-- | Reads specified configs. +readConfigs + :: CConfig Option -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigs cmdlineConfig configPaths = do + configs <- readConfig `mapM` configPaths + let merged = Semigroup.mconcat $ reverse (cmdlineConfig:catMaybes configs) + return $ cZipWith fromOptionIdentity staticDefaultConfig merged + +-- | Reads provided configs +-- but also applies the user default configuration (with a lowest priority) +readConfigsWithUserConfig + :: CConfig Option -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigsWithUserConfig cmdlineConfig configPaths = do + defaultPath <- liftIO $ userConfigPath + readConfigs cmdlineConfig (configPaths ++ [defaultPath]) + writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () writeDefaultConfig path = liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap diff --git a/stack.yaml b/stack.yaml index 74e27d2..3362823 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,7 @@ -resolver: lts-10.0 +resolver: lts-10.5 packages: - . + +extra-deps: + - butcher-1.3.0.0 -- 2.30.2 From af7f9017b82d9fa9d8886716a7e82cd2e9854dd9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 11 Mar 2018 22:07:12 +0100 Subject: [PATCH 111/478] Fix Alt-transformation bug with BDFEnsureIndents multiple BDFEnsureIndent nodes were mistreated previously --- .../Brittany/Internal/Transformations/Alt.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 93c31c6..9c0a34e 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -319,11 +319,16 @@ transformAlts briDoc = BrIndentNone -> 0 BrIndentRegular -> indAmount BrIndentSpecial i -> i - mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid, - -- in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = _acp_line acp + indAdd - } + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } r <- rec bd acp' <- mGet mSet $ acp' { _acp_indent = _acp_indent acp } -- 2.30.2 From 20f9c009ee18e18ca5c4d4db440f4e565757cbc4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 11 Mar 2018 22:42:47 +0100 Subject: [PATCH 112/478] Stop hanging indent for IEThingWith plus minor refactors/cleanups this is more in line with IndentPolicyLeft and imo also looks nicer in general --- src-literatetests/10-tests.blt | 40 +++++++++------- src-literatetests/tests-context-free.blt | 37 +++++++------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 48 ++++++++++++------- .../Brittany/Internal/Layouters/Import.hs | 22 +++++++-- 4 files changed, 90 insertions(+), 57 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 3a5941c..802a6fc 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -787,27 +787,33 @@ import Test ( -- comment ) #test long-bindings -import Test ( longbindingNameThatoverflowsColum ) -import Test ( Long( List - , Of - , Things - ) ) +import Test ( longbindingNameThatoverflowsColum + ) +import Test ( Long + ( List + , Of + , Things + ) + ) #test things-with-with-comments -import Test ( Thing( -- Comments - ) +import Test ( Thing + ( -- Comments + ) ) -import Test ( Thing( Item - -- and Comment - ) +import Test ( Thing + ( Item + -- and Comment + ) ) -import Test ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) +import Test ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) ) #test prefer-dense-empty-list import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index d1a27b3..8ab4d7e 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -792,27 +792,30 @@ import Test (Long(List, Of, Things)) #test things-with-with-comments import Test - ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) ) import Test - ( Thing( Item - -- and Comment - ) + ( Thing + ( Item + -- and Comment + ) ) import Test - ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) ) #test prefer-dense-empty-list diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index ebf9b36..126d519 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -47,10 +47,16 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingWith _ _ ns _ -> do hasComments <- hasAnyCommentsBelow lie docAltFilter - [(not hasComments, docSeq $ [ien, docLit $ Text.pack "("] + [ ( not hasComments + , docSeq + $ [ien, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) - ++ [docParenR]) - ,(otherwise, docSeq [ien, layoutItems (splitFirstLast ns)]) + ++ [docParenR] + ) + , (otherwise + , docAddBaseY BrIndentRegular + $ docPar ien (layoutItems (splitFirstLast ns)) + ) ] where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName @@ -113,21 +119,27 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- ) layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered layoutLLIEs llies = do - ieDs <- layoutAnnAndSepLLIEs llies + ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies case ieDs of [] -> docAltFilter - [ (not hasComments, docLit $ Text.pack "()") - , ( hasComments - , docPar - (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - ) - ] - (ieDsH:ieDsT) -> - docAltFilter - [ (not hasComments, docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR]) - , (otherwise, docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ - docLines $ ieDsT - ++ [docParenR]) - ] + [ (not hasComments, docLit $ Text.pack "()") + , ( hasComments + , docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + ) + ] + (ieDsH:ieDsT) -> docAltFilter + [ ( not hasComments + , docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + ) + , ( otherwise + , docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] + ) + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 5fa05a2..613f2d2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -95,9 +95,22 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of docParenR else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] -- ..[hiding].( b ) - [ieD] -> if hasComments - then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR - else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] + [ieD] -> docAltFilter + [ ( not hasComments + , docSeq + [ hidDoc + , docParenLSep + , docForceSingleline $ ieD + , docSeparator + , docParenR + ] + ) + , ( otherwise + , docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + docParenR + ) + ] -- ..[hiding].( b -- , b' -- ) @@ -114,8 +127,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of then let asDoc = maybe docEmpty makeAsDoc masT in docAlt - [ docForceSingleline $ - docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] , docAddBaseY BrIndentRegular $ docPar (docSeq [importHead, asDoc]) bindingsD ] -- 2.30.2 From 9531edb2a79d7e53e8fad06726b72f6c675ce6fc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 16:29:47 +0100 Subject: [PATCH 113/478] Improve module layouting in two aspects - IEThingWith in export list can now be single-line - Now respect offset of the "module" keyword (retain empty lines after pragmas, for example) --- src-literatetests/10-tests.blt | 9 +++ src/Language/Haskell/Brittany/Internal.hs | 62 +++++++++++------- .../Haskell/Brittany/Internal/Backend.hs | 19 ++++++ .../Brittany/Internal/LayouterBasics.hs | 18 ++++++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 6 +- .../Brittany/Internal/Layouters/Import.hs | 2 +- .../Brittany/Internal/Layouters/Module.hs | 64 ++++++++++--------- .../Brittany/Internal/Transformations/Alt.hs | 4 ++ .../Internal/Transformations/Columns.hs | 1 + .../Haskell/Brittany/Internal/Types.hs | 5 ++ 10 files changed, 131 insertions(+), 59 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 802a6fc..c57e33a 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -625,6 +625,15 @@ module Main (module Main) where #test export-with-things module Main (Test(Test, a, b)) where +#test export-with-things-comment +-- comment1 + +module Main + ( Test(Test, a, b) + , foo -- comment2 + ) -- comment3 +where + #test export-with-empty-thing module Main (Test()) where diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 25b7b9a..a283e89 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -16,7 +16,7 @@ where #include "prelude.inc" import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data @@ -133,7 +133,7 @@ parsePrintModule configRaw inputText = runExceptT $ do -- can occur. pPrintModule :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf anns parsedModule = @@ -169,7 +169,7 @@ pPrintModule conf anns parsedModule = -- if it does not. pPrintModuleAndCheck :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf anns parsedModule = do @@ -253,7 +253,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations @@ -266,26 +266,26 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do ppDecl decl let finalComments = filter ( fst .> \case - ExactPrint.Types.AnnComment{} -> True + ExactPrint.AnnComment{} -> True _ -> False ) post post `forM_` \case - (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do + (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr - (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) -> + (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> let - folder (acc, _) (kw, ExactPrint.Types.DP (x, y)) = case kw of - ExactPrint.Types.AnnComment cm - | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm - -> ( acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , y + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span ) - _ -> (acc + x, y) - (cmX, cmY) = foldl' folder (0, 0) finalComments + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments in - ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY) + ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () @@ -323,23 +323,23 @@ ppDecl d@(L loc decl) = case decl of -- Prints the information associated with the module annotation -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule RdrName) - -> PPM [(ExactPrint.Types.KeywordId, ExactPrint.Types.DeltaPos)] + -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey lmod) annMap + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) -- modules to both HsModule and the elements in the module -- this can cause duplication of comments. So strip -- attached annotations that come after the module's where -- from the module node let (filteredAnns', post) = - case (ExactPrint.Types.mkAnnKey lmod) `Map.lookup` filteredAnns of + case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> - let modAnnsDp = ExactPrint.Types.annsDP mAnn - isWhere (ExactPrint.Types.G AnnWhere) = True + let modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True isWhere _ = False - isEof (ExactPrint.Types.G AnnEofPos) = True + isEof (ExactPrint.G AnnEofPos) = True isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp @@ -348,8 +348,22 @@ ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.Types.annsDP = pre } - filteredAnns'' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' filteredAnns + findInitialCommentSize = \case + ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)):rest) -> + let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm + in y + + GHC.srcSpanEndLine span + - GHC.srcSpanStartLine span + + findInitialCommentSize rest + _ -> 0 + initialCommentSize = findInitialCommentSize pre + fixAbsoluteModuleDP = \case + (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> + (g, ExactPrint.DP (y - initialCommentSize, x)) + x -> x + pre' = map fixAbsoluteModuleDP pre + mAnn' = mAnn { ExactPrint.annsDP = pre' } + filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns in (filteredAnns'', post') in do traceIfDumpConf "bridoc annotations filtered/transformed" @@ -415,7 +429,7 @@ layoutBriDoc briDoc = do -- simpl <- mGet <&> transformToSimple -- return simpl - anns :: ExactPrint.Types.Anns <- mAsk + anns :: ExactPrint.Anns <- mAsk let state = LayoutState { _lstate_baseYs = [0] diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index c121eaf..c9da940 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -250,6 +250,23 @@ layoutBriDocM = \case -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDMoveToKWDP annKey keyword bd -> do + mDP <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let relevant = [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] + pure $ case relevant of + [] -> Nothing + (dp:_) -> Just dp + case mDP of + Nothing -> pure () + Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y x + layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd @@ -282,6 +299,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ bd -> rec bd BDLines ls@(_:_) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x @@ -317,6 +335,7 @@ briDocIsMultiLine briDoc = rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ bd -> rec bd BDLines (_:_:_) -> True BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 151dd65..89c8ae3 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -16,6 +16,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSeq , docPar , docNodeAnnKW + , docNodeMoveToKWDP , docWrapNode , docWrapNodePrior , docWrapNodeRest @@ -29,6 +30,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docAnnotationPrior , docAnnotationKW , docAnnotationRest + , docMoveToKWDP , docNonBottomSpacing , docSetParSpacing , docForceParSpacing @@ -441,6 +443,13 @@ docAnnotationKW -> ToBriDocM BriDocNumbered docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm +docMoveToKWDP + :: AnnKey + -> AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docMoveToKWDP annKey kw bdm = allocateNode . BDFMoveToKWDP annKey kw =<< bdm + docAnnotationRest :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm @@ -481,6 +490,15 @@ docNodeAnnKW docNodeAnnKW ast kw bdm = docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm +docNodeMoveToKWDP + :: Data.Data.Data ast + => Located ast + -> AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docNodeMoveToKWDP ast kw bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw bdm + class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 126d519..bc277bc 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -117,8 +117,8 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered -layoutLLIEs llies = do +layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies case ieDs of @@ -130,7 +130,7 @@ layoutLLIEs llies = do ) ] (ieDsH:ieDsT) -> docAltFilter - [ ( not hasComments + [ ( not hasComments && enableSingleline , docSeq $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 613f2d2..e7fb03c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -84,7 +84,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docSeq [hidDoc, layoutLLIEs llies] + then docSeq [hidDoc, layoutLLIEs True llies] else do ieDs <- layoutAnnAndSepLLIEs llies docWrapNodeRest llies $ case ieDs of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index db2e2af..4620307 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -24,35 +24,37 @@ import Language.Haskell.Brittany.Internal.Utils layoutModule :: ToBriDoc HsModule -layoutModule lmod@(L _ mod') = - case mod' of +layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports - HsModule (Just n) les imports _ _ _ -> do - let tn = Text.pack $ moduleNameString $ unLoc n - exportsDoc = maybe docEmpty layoutLLIEs les - docLines - $ docSeq - [ docWrapNode lmod docEmpty - -- A pseudo node that serves merely to force documentation - -- before the node - , docAlt - ( [ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , appSep exportsDoc - , docLit $ Text.pack "where" - ] - ] - ++ [ docLines - [ docAddBaseY BrIndentRegular $ docPar - ( docSeq - [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docForceMultiline exportsDoc) - , docLit $ Text.pack "where" - ] - ] - ) - ] - : map layoutImport imports + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> do + let tn = Text.pack $ moduleNameString $ unLoc n + docLines + $ docSeq + [ docNodeAnnKW lmod Nothing docEmpty + -- A pseudo node that serves merely to force documentation + -- before the node + , docNodeMoveToKWDP lmod AnnModule $ docAlt + ( [ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True x + , docLit $ Text.pack "where" + ] + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + ) + , docLit $ Text.pack "where" + ] + ] + ) + ] + : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 9c0a34e..c83cfae 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -301,6 +301,8 @@ transformAlts briDoc = reWrap . BDFAnnotationRest annKey <$> rec bd BDFAnnotationKW annKey kw bd -> reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw bd -> + reWrap . BDFMoveToKWDP annKey kw <$> rec bd BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines (l:lr) -> do ind <- _acp_indent <$> mGet @@ -460,6 +462,7 @@ getSpacing !bridoc = rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False @@ -705,6 +708,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw bd -> rec bd BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_:_) -> do -- we simply assume that lines is only used "properly", i.e. in diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 071028a..41290a7 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -128,6 +128,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDAnnotationPrior{} -> Nothing BDAnnotationKW{} -> Nothing BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing BDEnsureIndent{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 2784c1d..d321e21 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -233,6 +233,7 @@ data BriDoc | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId BriDoc | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -278,6 +279,7 @@ data BriDocF f | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId (f (BriDocF f)) | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) @@ -311,6 +313,7 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw bd) = plate BDMoveToKWDP |- annKey |- kw |* bd uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd @@ -342,6 +345,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFMoveToKWDP annKey kw bd -> BDMoveToKWDP annKey kw $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd @@ -377,6 +381,7 @@ briDocSeqSpine = \case BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDMoveToKWDP _annKey _kw bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd -- 2.30.2 From 833ac95fd7ce764e93e2a4b20cda6c81341f1b53 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 17:11:25 +0100 Subject: [PATCH 114/478] Add two config options to control preamble layouting --- src-literatetests/Main.hs | 2 + src-unittests/TestUtils.hs | 2 + src/Language/Haskell/Brittany/Internal.hs | 101 ++++++++++-------- .../Haskell/Brittany/Internal/Config.hs | 4 + .../Haskell/Brittany/Internal/Config/Types.hs | 15 +++ .../Brittany/Internal/Layouters/Module.hs | 14 +-- 6 files changed, 87 insertions(+), 51 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 5567e68..47fd801 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -174,6 +174,8 @@ defaultTestConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 1ee5203..2e9487c 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -56,6 +56,8 @@ defaultTestConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index a283e89..561390f 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -324,7 +324,7 @@ ppDecl d@(L loc decl) = case decl of -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule RdrName) -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do +ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) @@ -332,52 +332,63 @@ ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do -- this can cause duplication of comments. So strip -- attached annotations that come after the module's where -- from the module node - let (filteredAnns', post) = - case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of - Nothing -> (filteredAnns, []) - Just mAnn -> - let modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.G AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post') = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - findInitialCommentSize = \case - ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)):rest) -> - let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm - in y - + GHC.srcSpanEndLine span - - GHC.srcSpanStartLine span - + findInitialCommentSize rest - _ -> 0 - initialCommentSize = findInitialCommentSize pre - fixAbsoluteModuleDP = \case - (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> - (g, ExactPrint.DP (y - initialCommentSize, x)) - x -> x - pre' = map fixAbsoluteModuleDP pre - mAnn' = mAnn { ExactPrint.annsDP = pre' } - filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in (filteredAnns'', post') - in do - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns' + config <- mAsk + let shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - config <- mAsk + let + (filteredAnns', post) = + case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let + modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + findInitialCommentSize = \case + ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)) : rest) -> + let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm + in y + + GHC.srcSpanEndLine span + - GHC.srcSpanStartLine span + + findInitialCommentSize rest + _ -> 0 + initialCommentSize = findInitialCommentSize pre + fixAbsoluteModuleDP = \case + (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> + (g, ExactPrint.DP (y - initialCommentSize, x)) + x -> x + pre' = if shouldReformatPreamble + then map fixAbsoluteModuleDP pre + else pre + mAnn' = mAnn { ExactPrint.annsDP = pre' } + filteredAnns'' = + Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns + in + (filteredAnns'', post') + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' - MultiRWSS.withoutMultiReader $ do - MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil - withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc - return post + if shouldReformatPreamble + then MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil + withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + else + let emptyModule = L loc m { hsmodDecls = [] } + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + return post _sigHead :: Sig RdrName -> String _sigHead = \case diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ad991b5..d9266a9 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -64,6 +64,8 @@ staticDefaultConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -158,6 +160,8 @@ configParser = do , _lconfig_alignmentLimit = mempty , _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index f2530b0..0f6d48b 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -84,6 +84,21 @@ data CLayoutConfig f = LayoutConfig -- -> SomeLongStuff -- As usual for hanging indentation, the result will be -- context-sensitive (in the function name). + , _lconfig_reformatModulePreamble :: f (Last Bool) + -- whether the module preamble/header (module keyword, name, export list, + -- import statements) are reformatted. If false, only the elements of the + -- module (everything past the "where") are reformatted. + , _lconfig_allowSingleLineExportList :: f (Last Bool) + -- if true, and it fits in a single line, and there are no comments in the + -- export list, the following layout will be used: + -- > module MyModule (abc, def) where + -- > [stuff] + -- otherwise, the multi-line version is used: + -- > module MyModule + -- > ( abc + -- > , def + -- > ) + -- > where } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 4620307..e9c9aa3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -29,13 +29,17 @@ layoutModule lmod@(L _ mod') = case mod' of HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports HsModule (Just n) les imports _ _ _ -> do let tn = Text.pack $ moduleNameString $ unLoc n + allowSingleLineExportList <- mAsk + <&> _conf_layout + .> _lconfig_allowSingleLineExportList + .> confUnpack docLines $ docSeq [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ docAlt - ( [ docForceSingleline $ docSeq + , docNodeMoveToKWDP lmod AnnModule $ docAltFilter + [ (,) allowSingleLineExportList $ docForceSingleline $ docSeq [ appSep $ docLit $ Text.pack "module" , appSep $ docLit tn , docWrapNode lmod $ appSep $ case les of @@ -43,8 +47,7 @@ layoutModule lmod@(L _ mod') = case mod' of Just x -> layoutLLIEs True x , docLit $ Text.pack "where" ] - ] - ++ [ docLines + , (,) otherwise $ docLines [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) @@ -54,7 +57,6 @@ layoutModule lmod@(L _ mod') = case mod' of ) , docLit $ Text.pack "where" ] - ] - ) + ] ] : map layoutImport imports -- 2.30.2 From 15d2250c0bbc6f10a03db8bc225001ccbe871de8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 17:21:28 +0100 Subject: [PATCH 115/478] Change _lconfig_importColumn default: 60 -> 50 --- src/Language/Haskell/Brittany/Internal/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index d9266a9..ea01253 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -58,7 +58,7 @@ staticDefaultConfig = Config , _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) -- 2.30.2 From 2128f7b3fbc95450da08be32963a90b2c7b3d10f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 18:28:10 +0100 Subject: [PATCH 116/478] Fixup stack.yaml --- stack.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/stack.yaml b/stack.yaml index 74e27d2..585eb87 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,7 @@ resolver: lts-10.0 packages: - . + +extra-deps: + - butcher-1.3.0.0 + - ghc-exactprint-0.5.6.0 -- 2.30.2 From c0ea20455cb0fa67721759a66e61b863954b49e3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Mar 2018 22:38:27 +0100 Subject: [PATCH 117/478] Fixup haddock typos --- src/Language/Haskell/Brittany/Internal/Config.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index fe1b317..666d1f4 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -234,8 +234,8 @@ readConfig path = do return $ Just fileConf else return $ Nothing --- | Returns a global brittany config file --- If there is no global config in a system, one will be created +-- | Looks for a user-global config file and return its path. +-- If there is no global config in a system, one will be created. userConfigPath :: IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" @@ -250,7 +250,7 @@ userConfigPath = do writeDefaultConfig $ createConfPath pure createConfPath --- | Searhes for a local brittany config path starting from a given directory +-- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do let dirParts = FilePath.splitDirectories dir @@ -269,7 +269,7 @@ readConfigs cmdlineConfig configPaths = do return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs --- but also applies the user default configuration (with a lowest priority) +-- but also applies the user default configuration (with lowest priority) readConfigsWithUserConfig :: CConfig Option -- ^ Explicit options, take highest priority -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first -- 2.30.2 From 60775bbc6292b7860385b10af002280e283e8828 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Mar 2018 23:24:05 +0100 Subject: [PATCH 118/478] Switch stack.yaml resolver to lts-11.0 --- stack.yaml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/stack.yaml b/stack.yaml index 3362823..1939eac 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,4 @@ -resolver: lts-10.5 +resolver: lts-11.0 packages: - . - -extra-deps: - - butcher-1.3.0.0 -- 2.30.2 From 1330aeb6b4d3a3138bca89e1f3ee966677ee93db Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Mar 2018 23:51:22 +0100 Subject: [PATCH 119/478] Fix ticked type operator losing tick (fixes #125) --- src-literatetests/15-regressions.blt | 3 +++ .../Brittany/Internal/LayouterBasics.hs | 22 +++++++++++++++++++ .../Brittany/Internal/Layouters/Type.hs | 7 +++--- 3 files changed, 29 insertions(+), 3 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 5e4f52c..0eec0be 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -524,3 +524,6 @@ spanKey p q = case minViewWithKey q of Just ((k, _), q') | p k -> let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') _ -> ([], q) + +#test issue 125 +a :: () ':- () diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 52c9e08..a013270 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -4,6 +4,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , lrdrNameToText , lrdrNameToTextAnn , lrdrNameToTextAnnTypeEqualityIsSpecial + , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments , filterAnns @@ -216,6 +217,27 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh else x +-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects +-- the annotations for a (parent) node for a tick to be added to the +-- literal. +-- Excessively long name to reflect on us having to work around such +-- excessively obscure special cases in the exactprint API. +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick + :: ( Data ast + , MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => Located ast + -> Located RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do + hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote + x <- lrdrNameToTextAnn ast2 + let lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + return $ if hasQuote then Text.cons '\'' lit else lit + askIndent :: (MonadMultiReader Config m) => m Int askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index bd4d728..11e0eed 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -317,7 +317,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsAppsTy [L _ (HsAppPrefix typ1)] -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 - HsAppsTy [_lname@(L _ (HsAppInfix name))] -> do + HsAppsTy [lname@(L _ (HsAppInfix name))] -> do -- this redirection is somewhat hacky, but whatever. -- TODO: a general problem when doing deep inspections on -- the type (and this is not the only instance) @@ -326,7 +326,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- circumstances exactly important annotations (comments) -- would be assigned to such constructors. typeDoc1 <- -- docSharedWrapper layoutType $ (L l $ HsTyVar name) - lrdrNameToTextAnnTypeEqualityIsSpecial name + lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lname name docLit typeDoc1 HsAppsTy (L _ (HsAppPrefix typHead):typRestA) | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t @@ -350,7 +350,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] where layoutAppType (L _ (HsAppPrefix t)) = layoutType t - layoutAppType (L _ (HsAppInfix t)) = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecial t + layoutAppType lt@(L _ (HsAppInfix t)) = + docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t HsListTy typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt -- 2.30.2 From 8de56ba11d4e2442a648f28573254edd5f54e403 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 21 Mar 2018 01:02:44 +0100 Subject: [PATCH 120/478] Support import column vs import-as column --- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + src/Language/Haskell/Brittany/Internal/Config.hs | 3 +++ src/Language/Haskell/Brittany/Internal/Config/Types.hs | 7 ++++++- src/Language/Haskell/Brittany/Internal/Layouters/Import.hs | 5 +++-- 5 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 47fd801..ebe2a08 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -169,6 +169,7 @@ defaultTestConfig = Config , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 2e9487c..d10f85a 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -51,6 +51,7 @@ defaultTestConfig = Config , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ea01253..d660e6e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -59,6 +59,7 @@ staticDefaultConfig = Config , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) @@ -106,6 +107,7 @@ configParser = do ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") @@ -155,6 +157,7 @@ configParser = do , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ , _lconfig_indentListSpecial = mempty -- falseToNothing _ , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol , _lconfig_altChooser = mempty , _lconfig_columnAlignMode = mempty , _lconfig_alignmentLimit = mempty diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 0f6d48b..03f7d9a 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -53,7 +53,12 @@ data CLayoutConfig f = LayoutConfig , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) + , _lconfig_importColumn :: f (Last Int) + -- ^ for import statement layouting, column at which to align the + -- elements to be imported from a module. + , _lconfig_importAsColumn :: f (Last Int) + -- ^ for import statement layouting, column at which put the module's + -- "as" name (which also affects the positioning of the "as" keyword). , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) , _lconfig_alignmentLimit :: f (Last Int) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index e7fb03c..a98f642 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -46,6 +46,7 @@ layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let compact = indentPolicy == IndentPolicyLeft @@ -136,9 +137,9 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] | otherwise -> docLines [importHead, asDoc, bindingLine] where - enoughRoom = nameCost < importCol - asCost + enoughRoom = nameCost < importAsCol - asCost asDoc = - docEnsureIndent (BrIndentSpecial (importCol - asCost)) + docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) $ makeAsDoc n Nothing | enoughRoom -> docSeq [importHead, bindingLine] | otherwise -> docLines [importHead, bindingLine] -- 2.30.2 From 487c32175ad72c5ebaef0ef6442cefa2e789e26b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Mar 2018 23:55:11 +0100 Subject: [PATCH 121/478] Refactor Alt.hs and Add out-commented alternative --- .../Brittany/Internal/Transformations/Alt.hs | 48 +++++++++++++++---- 1 file changed, 38 insertions(+), 10 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index c83cfae..f7ed523 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -72,12 +72,11 @@ transformAlts ) => BriDocNumbered -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts briDoc = +transformAlts = MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) - $ Memo.startEvalMemoT - $ fmap unwrapBriDocNumbered - $ rec - $ briDoc + . Memo.startEvalMemoT + . fmap unwrapBriDocNumbered + . rec where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) @@ -721,11 +720,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc $ sequence $ reverse $ lSpss - summed = worbled <&> \lSps@(lSp1:_) -> - VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - return $ summed + sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + sumF [] = error $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled -- lSpss@(mVs:_) <- rec `mapM` ls -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only -- -- consider the first alternative for the @@ -758,6 +758,34 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParAlways i -> VerticalSpacingParAlways i VerticalSpacingParSome i -> VerticalSpacingParAlways i } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } -- 2.30.2 From 46de13256bde47c8fe48d5af2ed6f54ed85afee3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Mar 2018 23:55:23 +0100 Subject: [PATCH 122/478] Add one more testcase --- src-literatetests/10-tests.blt | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index c57e33a..3410785 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -235,6 +235,17 @@ func -> ColInfo -> m () +#test forall context multiline with comments +{-# LANGUAGE RankNTypes #-} +addFlagStringParam + :: forall f out + . (Applicative f) + => String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> String -- ^ param name + -> Flag String -- ^ properties + -> CmdParser f out String + #test language pragma issue {-# LANGUAGE ScopedTypeVariables #-} func :: forall (a :: *) b . a -> b -- 2.30.2 From 90a2f65ba7f4da736567035525f565f993dc5dce Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 22 Mar 2018 01:19:56 +0100 Subject: [PATCH 123/478] Align applications on for same function, plus minor fixup Arguments of two function applications will only be aligned if the same function is called in both cases. The column transform was altered slightly to fix #65 properly as well. fixes #65, #128 --- src-literatetests/15-regressions.blt | 20 +++++++++++++++++++ .../Haskell/Brittany/Internal/Backend.hs | 2 +- .../Brittany/Internal/Layouters/Expr.hs | 6 +++++- .../Internal/Transformations/Columns.hs | 11 +++++----- .../Haskell/Brittany/Internal/Types.hs | 2 +- 5 files changed, 33 insertions(+), 8 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0eec0be..3a0b19d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -501,6 +501,21 @@ func -> Proxy (str :: [*]) -> m (Tagged str String) +#test issue 65 +widgetsDyn = + [ [ vBox + [ padTop Max outputLinesWidget + , padRight Max wid1 <+> flowWidget -- alignment here is strange/buggy + , padBottom (Pad 5) help + ] + ] + | wid1 <- promptDyn + , (flowWidget, _) <- flowResultD + , outputLinesWidget <- outputLinesWidgetD + , help <- suggestionHelpBox + , parser <- cmdParserD + ] + #test issue 67 fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) @@ -527,3 +542,8 @@ spanKey p q = case minViewWithKey q of #test issue 125 a :: () ':- () + +#test issue 128 +func = do + createDirectoryIfMissing True path + openFile fileName AppendMode diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index c9da940..a22d756 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -455,7 +455,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do (BDCols ColRecUpdate _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False - (BDCols ColApp _) -> True + (BDCols ColApp{} _) -> True (BDCols ColTuple _) -> False (BDCols ColTuples _) -> False (BDCols ColOpPrefix _) -> False diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 807aad8..4aca92f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -117,12 +117,16 @@ layoutExpr lexpr@(L _ expr) = do (L _ (HsApp l r)) -> gather (r:list) l x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 + let colsOrSequence = case headE of + L _ (HsVar (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs docAltFilter [ -- foo x y ( True - , docCols ColApp + , colsOrSequence $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 41290a7..471ac67 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -23,11 +23,12 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDLit{} -> Nothing BDSeq list | any (\case BDSeq{} -> True BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ - filter isNotEmpty list >>= \case - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) -> + _ -> False) list -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) + | all (\case BDSeparator -> True; _ -> False) rest -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) BDLines lines | any (\case BDLines{} -> True BDEmpty{} -> True diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index d321e21..1d26b73 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -174,7 +174,7 @@ data ColSig | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? | ColListComp | ColList - | ColApp + | ColApp Text | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? -- 2.30.2 From d634d34ff1ee83c7925e21639c8c0e60f6faf4a3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 15:41:41 +0100 Subject: [PATCH 124/478] Fix module-import-hiding-items layout --- src-literatetests/10-tests.blt | 19 +++- src-literatetests/tests-context-free.blt | 21 ++++- .../Haskell/Brittany/Internal/Config/Types.hs | 2 + .../Brittany/Internal/Layouters/Import.hs | 93 ++++++++++--------- .../Internal/Transformations/Floating.hs | 4 +- 5 files changed, 89 insertions(+), 50 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 3410785..4919f3f 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -734,19 +734,22 @@ import Test hiding ( ) import Test as T hiding ( ) -#test long-module-name +#test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne ( ) import TestJustAbitToLongModuleNameLikeThisOneIs ( ) +#test long-module-name-as import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T +#test long-module-name-hiding import TestJustShortEnoughModuleNameLike hiding ( ) import TestJustAbitToLongModuleNameLikeTh hiding ( ) +#test long-module-name-simple-items import MoreThanSufficientlyLongModuleNameWithSome ( items , that @@ -758,6 +761,20 @@ import MoreThanSufficientlyLongModuleNameWithSome , layout ) +#test long-module-name-hiding-items +import TestJustShortEnoughModuleNameLike hiding ( abc + , def + , ghci + , jklm + ) +import TestJustAbitToLongModuleNameLikeTh + hiding ( abc + , def + , ghci + , jklm + ) + +#test long-module-name-other import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe ( ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 8ab4d7e..2d1c421 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -736,16 +736,27 @@ import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) import Test hiding () import Test as T hiding () -#test long-module-name +#test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne () import TestJustAbitToLongModuleNameLikeThisOneIs () -import TestJustShortEnoughModuleNameLikeThisOn as T -import TestJustAbitToLongModuleNameLikeThisOneI as T -import TestJustShortEnoughModuleNameLike hiding () -import TestJustAbitToLongModuleNameLikeTh hiding () import MoreThanSufficientlyLongModuleNameWithSome (items, that, will, not, fit, inA, compact, layout) +#test long-module-name-as +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI as T + +#test long-module-name-hiding +import TestJustShortEnoughModuleNameLike hiding () +import TestJustAbitToLongModuleNameLikeTh hiding () + +#test long-module-name-simple-items +import MoreThanSufficientlyLongModuleNameWithSome + (items, that, will, not, fit, inA, compact, layout) + +#test long-module-name-hiding-items +import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) + #test import-with-comments -- Test import Data.List (nub) -- Test diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 03f7d9a..dc0300f 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -56,9 +56,11 @@ data CLayoutConfig f = LayoutConfig , _lconfig_importColumn :: f (Last Int) -- ^ for import statement layouting, column at which to align the -- elements to be imported from a module. + -- It is expected that importAsColumn >= importCol. , _lconfig_importAsColumn :: f (Last Int) -- ^ for import statement layouting, column at which put the module's -- "as" name (which also affects the positioning of the "as" keyword). + -- It is expected that importAsColumn >= importCol. , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) , _lconfig_alignmentLimit :: f (Last Int) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index a98f642..04925bd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -64,7 +64,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of qLength = max minQLength qLengthReal -- Cost in columns of importColumn asCost = length "as " - bindingCost = if hiding then length "hiding ( " else length "( " + hidingParenCost = if hiding then length "hiding ( " else length "( " nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" @@ -77,8 +77,11 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of if compact then id else docEnsureIndent (BrIndentSpecial qLength) modNameD = indentName $ appSep $ docLit modNameT - hidDoc = - if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 + hidDocColDiff = importCol - 2 - hidDocCol + hidDoc = if hiding + then appSep $ docLit $ Text.pack "hiding" + else docEmpty importHead = docSeq [importQualifiers, modNameD] bindingsD = case mllies of Nothing -> docEmpty @@ -88,40 +91,43 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of then docSeq [hidDoc, layoutLLIEs True llies] else do ieDs <- layoutAnnAndSepLLIEs llies - docWrapNodeRest llies $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - docParenR - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> docAltFilter - [ ( not hasComments - , docSeq - [ hidDoc - , docParenLSep - , docForceSingleline $ ieD - , docSeparator - , docParenR - ] - ) - , ( otherwise - , docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - docParenR - ) - ] - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - $ docLines - $ ieDs' - ++ [docParenR] - bindingLine = - docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) $ docParenR) + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> docAltFilter + [ ( not hasComments + , docSeq + [ hidDoc + , docParenLSep + , docForceSingleline $ ieD + , docSeparator + , docParenR + ] + ) + , ( otherwise + , docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + ) + ] + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + ( docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] if compact @@ -134,14 +140,17 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ] else case masT of - Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] - | otherwise -> docLines [importHead, asDoc, bindingLine] + Just n -> if enoughRoom + then docLines + [ docSeq [importHead, asDoc], bindingsD] + else docLines [importHead, asDoc, bindingsD] where enoughRoom = nameCost < importAsCol - asCost asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) $ makeAsDoc n - Nothing | enoughRoom -> docSeq [importHead, bindingLine] - | otherwise -> docLines [importHead, bindingLine] - where enoughRoom = nameCost < importCol - bindingCost + Nothing -> if enoughRoom + then docSeq [importHead, bindingsD] + else docLines [importHead, bindingsD] + where enoughRoom = nameCost < importCol - hidingParenCost _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index e36a545..08a919f 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -101,9 +101,9 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDDebug s (BDIndentLevelPop x) _ -> Nothing descendAddB = transformDownMay $ \case - -- AddIndent floats into Lines. BDAddBaseY BrIndentNone x -> Just x + -- AddIndent floats into Lines. BDAddBaseY indent (BDLines lines) -> Just $ BDLines $ BDAddBaseY indent <$> lines -- AddIndent floats into last column @@ -145,9 +145,9 @@ transformSimplifyFloating = stepBO .> stepFull x -> x stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ Uniplate.rewrite $ \case - -- AddIndent floats into Lines. BDAddBaseY BrIndentNone x -> Just $ x + -- AddIndent floats into Lines. BDAddBaseY indent (BDLines lines) -> Just $ BDLines $ BDAddBaseY indent <$> lines -- AddIndent floats into last column -- 2.30.2 From a003b932a97b52d6e013786cc3e3e07884b7d1af Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 16:55:09 +0100 Subject: [PATCH 125/478] Fix comments in tuples being dropped (fixes #37) --- src-literatetests/15-regressions.blt | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 8 ++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 3a0b19d..91038fc 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -373,6 +373,16 @@ runBrittany tabSize text = do } parsePrintModule config text +#test issue 37 + +foo = + ( a + , -- comment1 + b + -- comment2 + , c + ) + #test issue 38 {-# LANGUAGE TypeApplications #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 4aca92f..d144b80 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -346,8 +346,12 @@ layoutExpr lexpr@(L _ expr) = do rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple args boxity -> do - let argExprs = fmap (\case (L _ (Present e)) -> Just e; (L _ (Missing PlaceHolder)) -> Nothing) args - argDocs <- docSharedWrapper (maybe docEmpty layoutExpr) `mapM` argExprs + let argExprs = args <&> \arg -> case arg of + (L _ (Present e)) -> (arg, Just e); + (L _ (Missing PlaceHolder)) -> (arg, Nothing) + argDocs <- forM argExprs + $ docSharedWrapper + $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") -- 2.30.2 From 3847325fd5a9413037c73f919a92772cbfe2f57c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 17:02:58 +0100 Subject: [PATCH 126/478] Omit single-line layout for OpApp with comments (fixes #111) --- src-literatetests/15-regressions.blt | 12 +++++++ .../Brittany/Internal/Layouters/Expr.hs | 31 +++++++++++-------- 2 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 91038fc..2127eaf 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -538,6 +538,18 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] {-# LANGUAGE TemplateHaskell #-} deriveFromJSON (unPrefix "assignPost") ''AssignmentPost +#test issue 111 + +alternatives :: Parser (Maybe Text) +alternatives = + alternativeOne -- first try this one + <|> alterantiveTwo -- then this one + <|> alternativeThree -- then this one + where + alternativeOne = purer "one" + alternativeTwo = purer "two" + alterantiveThree = purer "three" + #test issue 116 {-# LANGUAGE BangPatterns #-} func = do diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index d144b80..98d3d10 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -237,24 +237,27 @@ layoutExpr lexpr@(L _ expr) = do ] opLastDoc <- docSharedWrapper layoutExpr expOp expLastDoc <- docSharedWrapper layoutExpr expRight + hasComments <- hasAnyCommentsBelow lexpr let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True - docAlt - [ docSeq - [ appSep $ docForceSingleline leftOperandDoc + docAltFilter + [ ( not hasComments , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - ) - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] + [ appSep $ docForceSingleline leftOperandDoc + , docSeq + $ (appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] + ) + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc + ] + ) -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) -- , docSetBaseY @@ -264,12 +267,14 @@ layoutExpr lexpr@(L _ expr) = do -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ) - , docPar + , (otherwise + , docPar leftOperandDoc ( docLines $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) + ) ] OpApp expLeft expOp _ expRight -> do expDocLeft <- docSharedWrapper layoutExpr expLeft -- 2.30.2 From bdd3b155f3e5be2e85a2edad381712ed37a4de4e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 17:11:39 +0100 Subject: [PATCH 127/478] Fix HsPar comment placement bug (see #111) --- src-literatetests/15-regressions.blt | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 2127eaf..0498b5d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -569,3 +569,13 @@ a :: () ':- () func = do createDirectoryIfMissing True path openFile fileName AppendMode + +#test hspar-comments + +alternatives :: Parser (Maybe Text) +alternatives = -- a + ( -- b + alternativeOne -- c + <|> alterantiveTwo -- d + <|> alternativeThree -- e + ) -- f diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 98d3d10..f8535e7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -327,7 +327,7 @@ layoutExpr lexpr@(L _ expr) = do , opDoc ] HsPar innerExp -> do - innerExpDoc <- docSharedWrapper layoutExpr innerExp + innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt [ docSeq [ docLit $ Text.pack "(" -- 2.30.2 From 08451427279f15751bd762135117591d7e6cd6dc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 17:34:36 +0100 Subject: [PATCH 128/478] Fix let-in comment placement bug (fixes #110) --- src-literatetests/15-regressions.blt | 10 +++++++++- .../Haskell/Brittany/Internal/Layouters/Expr.hs | 16 +++++++++------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0498b5d..d84ec79 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -538,8 +538,16 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] {-# LANGUAGE TemplateHaskell #-} deriveFromJSON (unPrefix "assignPost") ''AssignmentPost -#test issue 111 +#test issue 110 +main = -- a + let --b + x = 1 -- x + y = 2 -- y + in do + print x + print y +#test issue 111 alternatives :: Parser (Maybe Text) alternatives = alternativeOne -- first try this one diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index f8535e7..a5402ea 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -543,7 +543,9 @@ layoutExpr lexpr@(L _ expr) = do (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) HsLet binds exp1 -> do expDoc1 <- docSharedWrapper layoutExpr exp1 - mBindDocs <- layoutLocalBinds binds + -- We jump through some ugly hoops here to ensure proper sharing. + mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) + =<< layoutLocalBinds binds let ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = @@ -560,7 +562,7 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline $ return bindDoc + , appSep $ docForceSingleline $ bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline $ expDoc1 ] @@ -569,12 +571,12 @@ layoutExpr lexpr@(L _ expr) = do [ docSeq [ appSep $ docLit $ Text.pack "let" , ifIndentLeftElse docForceSingleline docSetBaseAndIndent - $ return bindDoc + $ bindDoc ] , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) + (docSetBaseAndIndent $ bindDoc) ] , docAlt [ docSeq @@ -607,7 +609,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + (docSetBaseAndIndent $ docLines $ bindDocs) , docSeq [ docLit $ Text.pack "in " , docAddBaseY BrIndentRegular $ expDoc1 @@ -618,7 +620,7 @@ layoutExpr lexpr@(L _ expr) = do , docLines [ docSeq [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs + , docSetBaseAndIndent $ docLines $ bindDocs ] , docSeq [ appSep $ docLit $ Text.pack "in " @@ -631,7 +633,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "in") -- 2.30.2 From 3b20d0275e99f311c50b11b97918c0c8cf867d09 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 19:32:30 +0100 Subject: [PATCH 129/478] Bump to 0.10.0.0, Add Changelog --- ChangeLog.md | 23 +++++++++++++++++++++++ brittany.cabal | 2 +- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 1b23e1e..253226b 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,28 @@ # Revision history for brittany +## 0.10.0.0 -- March 2018 + +* Implement module/exports/imports layouting (thanks to sniperrifle2004) +* Expose config paths/parsing functions (thanks to Alexey Raga) +* Bugfixes: + - Fix layouting of `NOINLINE` pragma + - Fix ticked type operator (e.g. `':-`) losing tick (#125) + - Fix alignment issue with cases involving operators (#65) + - Fix comments in tuples being dropped (#37) + - Fix comment placements with let-in (#110) +* Layouting changes: + - Align arguments only if it is the same function being called (#128) + - Do not use single-line layout when infix operator expression contains + comments (#111) +* New layouting config items: + - `lconfig_importColumn`/`--import-col`: column for import items + - `lconfig_importAsColumn`/`--import-as-col`: column for the "as" name of + a module + - `lconfig_reformatModulePreamble`: controls module/export/import layouting + (default True) + - `lconfig_allowSingleLineExportList`: permit one-line module header, e.g. + `module Main (main)` (default False) + ## 0.9.0.1 -- February 2018 * Support `TupleSections` (thanks to Matthew Piziak) diff --git a/brittany.cabal b/brittany.cabal index f081f77..d87cbc8 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.9.0.1 +version: 0.10.0.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 8cabd0847737d122a77b7fd30b28498be806cf48 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 16:06:36 +0200 Subject: [PATCH 130/478] Update README.md and commandline description --- README.md | 12 ++++++------ src-brittany/Main.hs | 5 +++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 42e7fa5..4987ffc 100644 --- a/README.md +++ b/README.md @@ -8,13 +8,12 @@ haskell source code formatter This project's goals roughly are to: - Always retain the semantics of the source being transformed; -- Be idempotent (this also directly ensures that only valid haskell is - produced); +- Be idempotent; - Support the full GHC-haskell syntax including syntactic extensions (but excluding `-XCPP` which is too hard); - Retain newlines and comments unmodified; - Be clever about using the available horizontal space while not overflowing - it if it cannot be avoided; + the column maximum if it cannot be avoided; - Be clever about aligning things horizontally (this can be turned off completely however); - Have linear complexity in the size of the input. @@ -27,8 +26,9 @@ size of the input (although the constant factor is not small). See But brittany is not finished yet, and there are some open issues that yet require fixing: -- **only type-signatures and function/value bindings** are processed; - other module elements (data-decls, classes, instances, imports/exports etc.) +- **only the module header (imports/exports), type-signatures and + function/value bindings** are processed; + other module elements (data-decls, classes, instances, etc.) are not transformed in any way; this extends to e.g. **bindings inside class instance definitions** - they **won't be touched** (yet). - By using `ghc-exactprint` as the parser, brittany supports full GHC @@ -47,7 +47,7 @@ require fixing: You can [paste haskell code over here](https://hexagoxel.de/brittany/) to test how it gets formatted by brittany. (Rg. privacy: the server does -log the size of the input, but _not_ the full requests.) +log the size of the input, but _not_ the full input/output of requests.) # Other usage notes diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 057ad24..73eccd0 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -63,7 +63,8 @@ helpDoc = PP.vcat $ List.intersperse (PP.text "") [ parDocW [ "Reformats one or more haskell modules." - , "Currently affects only type signatures and function bindings;" + , "Currently affects only the module head (imports/exports), type" + , "signatures and function bindings;" , "everything else is left unmodified." , "Based on ghc-exactprint, thus (theoretically) supporting all" , "that ghc does." @@ -71,7 +72,7 @@ helpDoc = PP.vcat $ List.intersperse , parDoc $ "Example invocations:" , PP.hang (PP.text "") 2 $ PP.vcat [ PP.text "brittany" - , PP.hang (PP.text " ") 2 $ PP.text "read from stdin, output to stdout" + , PP.nest 2 $ PP.text "read from stdin, output to stdout" ] , PP.hang (PP.text "") 2 $ PP.vcat [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" -- 2.30.2 From b142837f1a6c97303d14f3c0600536a594c2945b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 16:58:17 +0200 Subject: [PATCH 131/478] Remove old bug notice from README.md [ci skip] --- README.md | 3 --- 1 file changed, 3 deletions(-) diff --git a/README.md b/README.md index 4987ffc..a3a106c 100644 --- a/README.md +++ b/README.md @@ -39,9 +39,6 @@ require fixing: 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.~~ - (fixed in `0.8.0.3`) ## Try without Installing -- 2.30.2 From f8c93e06f4ba44b9b15ef5c89021c182aceb4879 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 17:47:40 +0200 Subject: [PATCH 132/478] Add showcase for module layouting [ci skip] --- doc/showcases/Module.md | 89 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 doc/showcases/Module.md diff --git a/doc/showcases/Module.md b/doc/showcases/Module.md new file mode 100644 index 0000000..ebde6a9 --- /dev/null +++ b/doc/showcases/Module.md @@ -0,0 +1,89 @@ + +Last updated for brittany version `0.10.0.0`. + +# Example layouting of the module header (exports/imports) + +## On default settings + +~~~~.hs +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Main + ( main + ) +where + +import qualified Paths_brittany +import Language.Haskell.Brittany + +import Network.Wai +import Network.HTTP.Types +import qualified Network.Wai.Handler.Warp as Warp + +import Data.String + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import Control.Monad.Loops + +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text + +import Data.Version ( showVersion ) + +import qualified System.Mem +import qualified Control.Concurrent +import Control.Concurrent.Async ( async + , waitEitherCatch + , waitEitherCatchCancel + ) +import qualified Data.Aeson as Aeson +import Data.Time.Clock +import Data.Time.Format +import Text.Parsec hiding ( (<|>) ) +~~~~ + +For long module names, things will be moved one line below and aligned as +before. Long identifiers may overflow our 80 column limit: + +~~~~.hs +import qualified Example.Very.Long.Module.Name.Internal + as T +import Example.Very.Long.Module.Name.Internal + ( a + , b + , c + ) +import Example.Very.Long.Module.Name.Internal + ( someVeryLongAndDescriptiveFunctionName + ) +~~~~ + +## Alternative setting + +If you have many long module names or use large identifiers, you might +be interested in these alternative settings: + +~~~~ +conf_layout: + lconfig_importColumn: 21 + lconfig_importAsColumn: 70 +~~~~ + +Now, our previous examples becomes: + +~~~~.hs +import qualified Example.Very.Long.Module.Name.Strict.Internal as T +import Example.Very.Long.Module.Name.Strict.Internal + ( a + , b + , c + ) +import Example.Very.Long.Module.Name.Strict.Internal + ( someVeryLongAndDescriptiveFunctionName + ) +~~~~ -- 2.30.2 From e9f764e0e7e8e76a93f2c3a4623daee7b0533c0c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 18:06:37 +0200 Subject: [PATCH 133/478] Add showcase for IndentPolicyLeft --- doc/showcases/Module.md | 53 +++++++++++++++++++++++++++++++---------- 1 file changed, 41 insertions(+), 12 deletions(-) diff --git a/doc/showcases/Module.md b/doc/showcases/Module.md index ebde6a9..31a062f 100644 --- a/doc/showcases/Module.md +++ b/doc/showcases/Module.md @@ -5,6 +5,16 @@ Last updated for brittany version `0.10.0.0`. ## On default settings +default settings are: + +~~~~ +conf_layout: + lconfig_indentPolicy: IndentPolicyFree + lconfig_importColumn: 50 + lconfig_importAsColumn: 50 +~~~~ + + ~~~~.hs {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -54,16 +64,16 @@ before. Long identifiers may overflow our 80 column limit: import qualified Example.Very.Long.Module.Name.Internal as T import Example.Very.Long.Module.Name.Internal - ( a - , b - , c + ( someFunc + , MyDataType + , globalConstant ) import Example.Very.Long.Module.Name.Internal ( someVeryLongAndDescriptiveFunctionName ) ~~~~ -## Alternative setting +## Alternative setting - long identifiers If you have many long module names or use large identifiers, you might be interested in these alternative settings: @@ -77,13 +87,32 @@ conf_layout: Now, our previous examples becomes: ~~~~.hs -import qualified Example.Very.Long.Module.Name.Strict.Internal as T -import Example.Very.Long.Module.Name.Strict.Internal - ( a - , b - , c - ) -import Example.Very.Long.Module.Name.Strict.Internal - ( someVeryLongAndDescriptiveFunctionName +import qualified Example.Very.Long.Module.Name.Internal as T +import Example.Very.Long.Module.Name.Internal + ( someFunc + , MyDataType + , globalConstant ) +import Example.Very.Long.Module.Name.Internal + ( someVeryLongAndDescriptiveFunctionName ) +~~~~ + +## Alternative setting - "IndentPolicyLeft" + +The global switch "indent policy" that has the rough intention of removing any +cases of "hanging indentation" also affects module layouting: + +~~~~ +conf_layout: + lconfig_indentPolicy: IndentPolicyLeft +~~~~ + +Now, our previous examples becomes: + +~~~~.hs +import qualified Example.Very.Long.Module.Name.Internal as T +import Example.Very.Long.Module.Name.Internal + (someFunc, MyDataType, globalConstant) +import Example.Very.Long.Module.Name.Internal + (someVeryLongAndDescriptiveFunctionName) ~~~~ -- 2.30.2 From b219a23684787dfaa4dbeb0fecd02a9c321a53db Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 2 Apr 2018 16:35:28 +0200 Subject: [PATCH 134/478] Fix warning about brittany.cabal (cabal-version-specification) --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index d87cbc8..7c6b574 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -15,7 +15,7 @@ maintainer: Lennart Spitzner copyright: Copyright (C) 2016-2017 Lennart Spitzner category: Language build-type: Simple -cabal-version: >=1.18 +cabal-version: 1.18 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues extra-doc-files: { -- 2.30.2 From b43ee432202281c66ae8a5c0e0fcb1edb0acf1f1 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 2 Apr 2018 17:11:53 +0200 Subject: [PATCH 135/478] Fix/Implement empty type constraint handling (fixes #133) --- src-literatetests/15-regressions.blt | 12 ++++++++++++ .../Haskell/Brittany/Internal/Layouters/Type.hs | 8 ++++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index d84ec79..d59b844 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -587,3 +587,15 @@ alternatives = -- a <|> alterantiveTwo -- d <|> alternativeThree -- e ) -- f + +#test issue 133 +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall a + . () + => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +func + :: () + => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 11e0eed..646f986 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -47,7 +47,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of t <- lrdrNameToTextAnn name docWrapNode name $ docLit t #endif - HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do + HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- bndrs `forM` \case (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) @@ -90,6 +90,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ]) ] contextDoc = case cntxtDocs of + [] -> docLit $ Text.pack "()" [x] -> x _ -> docAlt [ let @@ -210,13 +211,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] - (HsQualTy (L _ []) _) -> - briDocByExactInlineOnly "HsQualTy [] _" ltype - HsQualTy lcntxts@(L _ cntxts@(_:_)) typ1 -> do + HsQualTy lcntxts@(L _ cntxts) typ1 -> do typeDoc <- docSharedWrapper layoutType typ1 cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let contextDoc = docWrapNode lcntxts $ case cntxtDocs of + [] -> docLit $ Text.pack "()" [x] -> x _ -> docAlt [ let -- 2.30.2 From e9689394b17f204ead6a33fb8d696ce74ab96b43 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 11:19:08 +0100 Subject: [PATCH 136/478] Add Semigroup instance for 'Max' monoid Otherwise ghc 8.4 will complain since Semigroup became a superclass of Monoid. --- src-brittany/Main.hs | 3 ++- src/Language/Haskell/Brittany/Internal/Prelude.hs | 6 ++++-- src/Language/Haskell/Brittany/Internal/Utils.hs | 5 ++++- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 73eccd0..7538411 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -11,6 +11,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Data.Map as Map +import qualified Data.Monoid import Text.Read (Read(..)) import qualified Text.ParserCombinators.ReadP as ReadP @@ -148,7 +149,7 @@ mainCmdParser helpDesc = do , PP.text "inplace: override respective input file (without backup!)" ] ) - <> flagDefault Display + Data.Monoid.<> flagDefault Display ) inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files") reorderStop diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 0ed9b6c..cc45d2a 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -255,14 +255,16 @@ import Debug.Trace as E ( trace import Foreign.ForeignPtr as E ( ForeignPtr ) -import Data.Monoid as E ( (<>) - , mconcat +import Data.Monoid as E ( mconcat , Monoid (..) ) import Data.Bifunctor as E ( bimap ) import Data.Functor as E ( (<$), ($>) ) import Data.Function as E ( (&) ) +import Data.Semigroup as E ( (<>) + , Semigroup(..) + ) import System.IO as E ( hFlush , stdout ) diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index b0896b8..aca6754 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -84,9 +84,12 @@ fromOptionIdentity x y = newtype Max a = Max { getMax :: a } deriving (Eq, Ord, Show, Bounded, Num) +instance (Num a, Ord a) => Semigroup (Max a) where + (<>) = Data.Coerce.coerce (max :: a -> a -> a) + instance (Num a, Ord a) => Monoid (Max a) where mempty = Max 0 - mappend = Data.Coerce.coerce (max :: a -> a -> a) + mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data -- 2.30.2 From 8410fbff8e4c076e97a1e840179f304186aa4010 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 11:20:06 +0100 Subject: [PATCH 137/478] Trailing whitespace --- .../Brittany/Internal/LayouterBasics.hs | 48 +++++++++---------- .../Haskell/Brittany/Internal/Prelude.hs | 2 +- .../Haskell/Brittany/Internal/Utils.hs | 2 +- 3 files changed, 26 insertions(+), 26 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 5fb5c8d..21d0f2f 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -297,10 +297,10 @@ allocNodeIndex = do -- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docEmpty = allocateNode BDFEmpty --- +-- -- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered -- docLit t = allocateNode $ BDFLit t --- +-- -- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) -- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered -- docExt x anns shouldAddComment = allocateNode $ BDFExternal @@ -308,51 +308,51 @@ allocNodeIndex = do -- (foldedAnnKeys x) -- shouldAddComment -- (Text.pack $ ExactPrint.exactPrint x anns) --- +-- -- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docAlt l = allocateNode . BDFAlt =<< sequence l --- --- +-- +-- -- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docSeq l = allocateNode . BDFSeq =<< sequence l --- +-- -- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docLines l = allocateNode . BDFLines =<< sequence l --- +-- -- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered -- docCols sig l = allocateNode . BDFCols sig =<< sequence l --- +-- -- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered -- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm --- +-- -- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm --- +-- -- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm --- +-- -- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docSeparator = allocateNode BDFSeparator --- +-- -- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered -- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm --- +-- -- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered -- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm --- +-- -- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm --- +-- -- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- appSep x = docSeq [x, docSeparator] --- +-- -- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docCommaSep = appSep $ docLit $ Text.pack "," --- +-- -- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docParenLSep = appSep $ docLit $ Text.pack "(" --- --- +-- +-- -- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) -- => Located ast -- -> m BriDocNumbered @@ -360,7 +360,7 @@ allocNodeIndex = do -- docPostComment ast bdm = do -- bd <- bdm -- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd --- +-- -- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) -- => Located ast -- -> m BriDocNumbered @@ -375,7 +375,7 @@ allocNodeIndex = do -- $ (,) i2 -- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) -- $ bd --- +-- -- docPar :: MonadMultiState NodeAllocIndex m -- => m BriDocNumbered -- -> m BriDocNumbered @@ -384,13 +384,13 @@ allocNodeIndex = do -- line <- lineM -- indented <- indentedM -- allocateNode $ BDFPar BrIndentNone line indented --- +-- -- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm --- +-- -- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm --- +-- -- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered -- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index cc45d2a..646ebb7 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -308,7 +308,7 @@ import Data.Tree as E ( Tree(..) import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) -- , MultiRWSTNull -- , MultiRWS - -- , + -- , MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiState(..) diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index aca6754..b454890 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -225,7 +225,7 @@ tellDebugMess :: MonadMultiWriter tellDebugMess s = mTell $ Seq.singleton s tellDebugMessShow :: forall a m . (MonadMultiWriter - (Seq String) m, Show a) => a -> m () + (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. -- 2.30.2 From 2ed9a13fdb022e17d877608a11465e92af975a03 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 2 Apr 2018 21:18:37 +0100 Subject: [PATCH 138/478] Replace 'docAltFilter' with 'runFilteredAlternative' --- .../Brittany/Internal/LayouterBasics.hs | 30 +- .../Brittany/Internal/Layouters/Decl.hs | 468 +++++++------- .../Brittany/Internal/Layouters/Expr.hs | 600 +++++++++--------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 39 +- .../Brittany/Internal/Layouters/Import.hs | 30 +- .../Brittany/Internal/Layouters/Module.hs | 42 +- .../Brittany/Internal/Layouters/Stmt.hs | 68 +- stack.yaml | 2 +- 8 files changed, 622 insertions(+), 657 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 21d0f2f..ec9d505 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Language.Haskell.Brittany.Internal.LayouterBasics ( processDefault , rdrNameToText @@ -11,7 +13,11 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docEmpty , docLit , docAlt - , docAltFilter + , CollectAltM + , addAlternativeCondM + , addAlternativeCond + , addAlternative + , runFilteredAlternative , docLines , docCols , docSeq @@ -60,6 +66,8 @@ where #include "prelude.inc" +import qualified Control.Monad.Writer.Strict as Writer + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types @@ -415,8 +423,24 @@ docExt x anns shouldAddComment = allocateNode $ BDFExternal docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt l = allocateNode . BDFAlt =<< sequence l -docAltFilter :: [(Bool, ToBriDocM BriDocNumbered)] -> ToBriDocM BriDocNumbered -docAltFilter = docAlt . map snd . filter fst +newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) + deriving (Functor, Applicative, Monad) + +addAlternativeCondM :: Bool -> CollectAltM (ToBriDocM BriDocNumbered) -> CollectAltM () +addAlternativeCondM cond doc = + addAlternativeCond cond =<< doc + +addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () +addAlternativeCond cond doc = + when cond (addAlternative doc) + +addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () +addAlternative = + CollectAltM . Writer.tell . (: []) + +runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered +runFilteredAlternative (CollectAltM action) = + docAlt $ Writer.execWriter action docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 400d422..d27c385 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -313,253 +313,231 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - docAltFilter - $ -- one-line solution - [ ( True - , 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) - [ ( True - , docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] + runFilteredAlternative $ do + + let wherePart = case mWhereDocs of + Nothing -> Just docEmpty + Just [w] -> Just $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> Nothing + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' ] ] - ++ wherePartMultiLine - ) - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ ( True - , docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] - ++ wherePartMultiLine - ) - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - ++ -- pattern and exactly one clause in single line, body as par; - -- where in following lines - [ ( True - , docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - ) - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - ++ -- pattern and exactly one clause in single line, body in new line. - [ ( True - , docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular - $ docNonBottomSpacing - $ (docAddBaseY BrIndentRegular $ return body) - ] - ++ wherePartMultiLine - ) - | [(guards, body, _)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - ++ -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - [ ( indentPolicy /= IndentPolicyLeft - , docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - ) - | Just patDoc <- [mPatDoc] - ] - ++ -- multiple clauses, each in a separate, single line - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - ) - ] - ++ -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - ) - ] - ++ -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular + $ docNonBottomSpacing + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine + + _ -> return () + + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] - ] - ++ wherePartMultiLine - ) - ] - ++ -- conservative approach: everything starts on the left. - [ ( True - , docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1:gr) -> - ( docSeq [appSep $ docLit $ Text.pack "|", return g1] - : ( gr - <&> \g -> - docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - ) - ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1:gr) -> + ( docSeq [appSep $ docLit $ Text.pack "|", return g1] + : ( gr + <&> \g -> + docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a5402ea..3240798 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -123,51 +123,46 @@ layoutExpr lexpr@(L _ expr) = do _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - docAltFilter - [ -- foo x y - ( True - , colsOrSequence + runFilteredAlternative $ do + -- foo x y + addAlternative + $ colsOrSequence $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) - ) - , -- foo x - -- y - ( allowFreeIndent - , docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ (docForceSingleline <$> paramDocs) - ] - ) - , -- foo - -- x - -- y - ( True - , docSetParSpacing + -- foo x + -- y + addAlternativeCond allowFreeIndent + $ docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY + $ docAddBaseY BrIndentRegular + $ docLines + $ (docForceSingleline <$> paramDocs) + ] + -- foo + -- x + -- y + addAlternative + $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docForceSingleline headDoc) ( docNonBottomSpacing $ docLines paramDocs ) - ) - , -- ( multi - -- line - -- function - -- ) - -- x - -- y - ( True - , docAddBaseY BrIndentRegular + -- ( multi + -- line + -- function + -- ) + -- x + -- y + addAlternative + $ docAddBaseY BrIndentRegular $ docPar headDoc ( docNonBottomSpacing $ docLines paramDocs ) - ) - ] HsApp exp1 exp2 -> do -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 @@ -243,39 +238,37 @@ layoutExpr lexpr@(L _ expr) = do | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True - docAltFilter - [ ( not hasComments + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ appSep $ docForceSingleline leftOperandDoc , docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - ) - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - ) + $ (appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] + ) + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc + ] -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) - -- , docSetBaseY - -- - $ docPar + -- addAlternative + -- $ docSetBaseY + -- $ docPar -- leftOperandDoc -- ( docLines - -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ) - , (otherwise - , docPar + addAlternative $ + docPar leftOperandDoc ( docLines $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) - ) - ] OpApp expLeft expOp _ expRight -> do expDocLeft <- docSharedWrapper layoutExpr expLeft expDocOp <- docSharedWrapper layoutExpr expOp @@ -285,42 +278,42 @@ layoutExpr lexpr@(L _ expr) = do | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True - docAltFilter - $ [ -- one-line - (,) True - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceSingleline expDocRight - ] - -- , -- line + freely indented block for right expression - -- docSeq - -- [ appSep $ docForceSingleline expDocLeft - -- , appSep $ docForceSingleline expDocOp - -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight - -- ] - , -- two-line - (,) True - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - ( docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - ) - , -- one-line + par - (,) allowPar - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceParSpacing expDocRight - ] - , -- more lines - (,) True - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) - ] + runFilteredAlternative $ do + -- one-line + addAlternative + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceSingleline expDocRight + ] + -- -- line + freely indented block for right expression + -- addAlternative + -- $ docSeq + -- [ appSep $ docForceSingleline expDocLeft + -- , appSep $ docForceSingleline expDocOp + -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight + -- ] + -- two-line + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + ( docForceSingleline + $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + ) + -- one-line + par + addAlternativeCond allowPar + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceParSpacing expDocRight + ] + -- more lines + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) NegApp op _ -> do opDoc <- docSharedWrapper layoutExpr op docSeq $ [ docLit $ Text.pack "-" @@ -380,24 +373,21 @@ layoutExpr lexpr@(L _ expr) = do , closeLit ] ] - FirstLast e1 ems eN -> - docAltFilter - [ (,) (not hasComments) - $ docCols ColTuple - ( [docSeq [openLit, docForceSingleline e1]] - ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] - ) - , (,) True - $ let - start = docCols ColTuples - [appSep $ openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] + ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) + ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + addAlternative $ + let + start = docCols ColTuples + [appSep $ openLit, e1] + linesM = ems <&> \d -> + docCols ColTuples [docCommaSep, d] + lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" @@ -432,10 +422,10 @@ layoutExpr lexpr@(L _ expr) = do _ -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. - docAltFilter - [ -- if _ then _ else _ - (,) (not hasComments) - $ docSeq + runFilteredAlternative $ do + -- if _ then _ else _ + addAlternativeCond (not hasComments) + $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc , appSep $ docLit $ Text.pack "then" @@ -443,106 +433,105 @@ layoutExpr lexpr@(L _ expr) = do , appSep $ docLit $ Text.pack "else" , docForceSingleline elseExprDoc ] - , -- either - -- if expr - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if expr - -- then - -- stuff - -- else - -- stuff - -- note that this has par-spacing - (,) True - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + -- either + -- if multi + -- line + -- condition + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if multi + -- line + -- condition + -- then + -- stuff + -- else + -- stuff + -- note that this does _not_ have par-spacing + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - , -- either - -- if multi - -- line - -- condition - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if multi - -- line - -- condition - -- then - -- stuff - -- else - -- stuff - -- note that this does _not_ have par-spacing - (,) True - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY maySpecialIndent + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + addAlternative + $ docSetBaseY + $ docLines + [ docAddBaseY maySpecialIndent $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - , (,) True - $ docSetBaseY - $ docLines - [ docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ] HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" hasComments <- hasAnyCommentsBelow lexpr docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) HsLet binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) =<< layoutLocalBinds binds @@ -590,7 +579,7 @@ layoutExpr lexpr@(L _ expr) = do ] ] ] - Just bindDocs@(_:_) -> docAltFilter + Just bindDocs@(_:_) -> runFilteredAlternative $ do --either -- let -- a = b @@ -604,43 +593,39 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - [ ( indentPolicy == IndentPolicyLeft - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ expDoc1 - ] + addAlternativeCond (indentPolicy == IndentPolicyLeft) + $ docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ expDoc1 ] - ) - , ( indentPolicy /= IndentPolicyLeft - , docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ bindDocs - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 - ] + ] + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ bindDocs ] - ) - , ( True - , docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 ] - ) - ] + ] + addAlternative + $ docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo DoExpr (L _ stmts) _ -> do @@ -660,11 +645,11 @@ layoutExpr lexpr@(L _ expr) = do HsDo x (L _ stmts) _ | case x of { ListComp -> True ; MonadComp -> True ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts hasComments <- hasAnyCommentsBelow lexpr - docAltFilter - [ (,) (not hasComments) - $ docSeq + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit @@ -678,8 +663,8 @@ layoutExpr lexpr@(L _ expr) = do $ fmap docForceSingleline $ List.init stmtDocs , docLit $ Text.pack " ]" ] - , (,) True - $ let + addAlternative $ + let start = docCols ColListComp [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" @@ -694,12 +679,11 @@ layoutExpr lexpr@(L _ expr) = do docCols ColListComp [docCommaSep, d] end = docLit $ Text.pack "]" in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - ] HsDo{} -> do -- TODO unknownNodeError "HsDo{} no comp" lexpr ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr + elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of FirstLastEmpty -> docSeq @@ -721,23 +705,21 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "]" ] ] - FirstLast e1 ems eN -> - docAltFilter - [ (,) (not hasComments) + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq $ [docLit $ Text.pack "["] ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) ++ [docLit $ Text.pack "]"] - , (,) True - $ let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> + docCols ColList [docCommaSep, d] + lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ExplicitList _ _ [] -> docLit $ Text.pack "[]" ExplicitPArr{} -> do @@ -870,67 +852,65 @@ layoutExpr lexpr@(L _ expr) = do return $ case ambName of Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - docAltFilter + runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } - [ ( True - , docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc - , appSep $ docLit $ Text.pack "{" - , appSep $ docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr - , docLit $ Text.pack "}" - ] - ) + addAlternative + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc + , appSep $ docLit $ Text.pack "{" + , appSep $ docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , docLit $ Text.pack "}" + ] -- hanging single-line fields -- container { fieldA = blub -- , fieldB = blub -- } - , ( indentPolicy /= IndentPolicyLeft - , docSeq - [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ docCommaSep + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" , docForceSingleline x ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit $ fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] - ] - ) - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - , ( True - , docSetParSpacing + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative + $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docNodeAnnKW lexpr Nothing $ rExprDoc) @@ -971,8 +951,6 @@ layoutExpr lexpr@(L _ expr) = do ] in [line1] ++ lineR ++ [lineN] ) - ) - ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #else /* ghc-8.0 */ diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bc277bc..61af2da 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -46,18 +46,15 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] IEThingWith _ _ ns _ -> do hasComments <- hasAnyCommentsBelow lie - docAltFilter - [ ( not hasComments - , docSeq + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq $ [ien, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR] - ) - , (otherwise - , docAddBaseY BrIndentRegular + addAlternative + $ docAddBaseY BrIndentRegular $ docPar ien (layoutItems (splitFirstLast ns)) - ) - ] where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] @@ -122,24 +119,20 @@ layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies case ieDs of - [] -> docAltFilter - [ (not hasComments, docLit $ Text.pack "()") - , ( hasComments - , docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - ) - ] - (ieDsH:ieDsT) -> docAltFilter - [ ( not hasComments && enableSingleline - , docSeq + [] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ + docLit $ Text.pack "()" + addAlternativeCond hasComments $ + docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH:ieDsT) -> runFilteredAlternative $ do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) ++ [docParenR] - ) - , ( otherwise - , docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ docLines $ ieDsT ++ [docParenR] - ) - ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 04925bd..7eb3e27 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -98,25 +98,21 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of [] -> if hasComments then docPar (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) $ docParenR) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] -- ..[hiding].( b ) - [ieD] -> docAltFilter - [ ( not hasComments - , docSeq - [ hidDoc - , docParenLSep - , docForceSingleline $ ieD - , docSeparator - , docParenR - ] - ) - , ( otherwise - , docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - ) - ] + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) -- ..[hiding].( b -- , b' -- ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index e9c9aa3..b959b28 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -38,25 +38,27 @@ layoutModule lmod@(L _ mod') = case mod' of [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ docAltFilter - [ (,) allowSingleLineExportList $ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True x - , docLit $ Text.pack "where" - ] - , (,) otherwise $ docLines - [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False x - ) - , docLit $ Text.pack "where" - ] - ] + , docNodeMoveToKWDP lmod AnnModule $ runFilteredAlternative $ do + addAlternativeCond allowSingleLineExportList $ + docForceSingleline + $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True x + , docLit $ Text.pack "where" + ] + addAlternative + $ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + ) + , docLit $ Text.pack "where" + ] ] : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index b8814cd..4128aea 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -71,46 +71,40 @@ layoutStmt lstmt@(L _ stmt) = do (docLit $ Text.pack "let") (docSetBaseAndIndent $ return bindDoc) ] - Just bindDocs -> docAltFilter - [ -- let aaa = expra - -- bbb = exprb - -- ccc = exprc - ( indentPolicy /= IndentPolicyLeft - , docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs - ] - ) - , -- let - -- aaa = expra - -- bbb = exprb - -- ccc = exprc - ( True - , docAddBaseY BrIndentRegular $ docPar + Just bindDocs -> runFilteredAlternative $ do + -- let aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + -- let + -- aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternative $ + docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - ) + RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do + -- rec stmt1 + -- stmt2 + -- stmt3 + addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts ] - RecStmt stmts _ _ _ _ _ _ _ _ _ -> docAltFilter - [ -- rec stmt1 - -- stmt2 - -- stmt3 - ( indentPolicy /= IndentPolicyLeft - , docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] - ) - , -- rec - -- stmt1 - -- stmt2 - -- stmt3 - ( True - , docAddBaseY BrIndentRegular - $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) - ) - ] + -- rec + -- stmt1 + -- stmt2 + -- stmt3 + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) BodyStmt expr _ _ _ -> do expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc diff --git a/stack.yaml b/stack.yaml index 1939eac..44e8d17 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.0 +resolver: lts-11.1 packages: - . -- 2.30.2 From 0dad5051df3aa3a0ca208f590b8503ad2b11374f Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:50:44 +0100 Subject: [PATCH 139/478] Remove redundant '$'s --- src/Language/Haskell/Brittany/Internal.hs | 4 +- .../Brittany/Internal/LayouterBasics.hs | 30 ++++---- .../Brittany/Internal/Layouters/Expr.hs | 68 +++++++++---------- .../Brittany/Internal/Layouters/Pattern.hs | 12 ++-- 4 files changed, 57 insertions(+), 57 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 561390f..e6a3c72 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -93,8 +93,8 @@ parsePrintModule configRaw inputText = runExceptT $ do cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE $ [ErrorInput err] - Right x -> pure $ x + Left err -> throwE [ErrorInput err] + Right x -> pure x (errsWarns, outputTextL) <- do let omitCheck = config diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index ec9d505..43b4b09 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -119,7 +119,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString $ str + _ -> mTell $ Text.Builder.fromString str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -174,7 +174,7 @@ briDocByExactInlineOnly infoStr ast = do False t let errorAction = do - mTell $ [ErrorUnknownNode infoStr ast] + mTell [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of @@ -589,7 +589,7 @@ instance DocWrapable a => DocWrapable [a] where docWrapNode ast bdsm = do bds <- bdsm case bds of - [] -> return $ [] -- TODO: this might be bad. maybe. then again, not really. well. + [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] @@ -601,23 +601,23 @@ instance DocWrapable a => DocWrapable [a] where docWrapNodePrior ast bdsm = do bds <- bdsm case bds of - [] -> return $ [] + [] -> return [] (bd1:bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return $ (bd1':bdR) + return (bd1':bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of - [] -> return $ [] + [] -> return [] (bdN:bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse $ (bdN':bdR) + return $ reverse (bdN':bdR) instance DocWrapable a => DocWrapable (Seq a) where docWrapNode ast bdsm = do bds <- bdsm case Seq.viewl bds of - Seq.EmptyL -> return $ Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. + Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. bd1 Seq.:< rest -> case Seq.viewr rest of Seq.EmptyR -> do bd1' <- docWrapNode ast (return bd1) @@ -629,14 +629,14 @@ instance DocWrapable a => DocWrapable (Seq a) where docWrapNodePrior ast bdsm = do bds <- bdsm case Seq.viewl bds of - Seq.EmptyL -> return $ Seq.empty + Seq.EmptyL -> return Seq.empty bd1 Seq.:< bdR -> do bd1' <- docWrapNodePrior ast (return bd1) return $ bd1' Seq.<| bdR docWrapNodeRest ast bdsm = do bds <- bdsm case Seq.viewr bds of - Seq.EmptyR -> return $ Seq.empty + Seq.EmptyR -> return Seq.empty bdR Seq.:> bdN -> do bdN' <- docWrapNodeRest ast (return bdN) return $ bdR Seq.|> bdN' @@ -647,19 +647,19 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where if null bds then do bd' <- docWrapNode ast (return bd) - return $ (bds, bd', x) + return (bds, bd', x) else do bds' <- docWrapNodePrior ast (return bds) bd' <- docWrapNodeRest ast (return bd) - return $ (bds', bd', x) + return (bds', bd', x) docWrapNodePrior ast stuffM = do (bds, bd, x) <- stuffM bds' <- docWrapNodePrior ast (return bds) - return $ (bds', bd, x) + return (bds', bd, x) docWrapNodeRest ast stuffM = do (bds, bd, x) <- stuffM bd' <- docWrapNodeRest ast (return bd) - return $ (bds, bd', x) + return (bds, bd', x) @@ -685,7 +685,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do - mTell $ [ErrorUnknownNode infoStr ast] + mTell [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3240798..c185482 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -61,7 +61,7 @@ layoutExpr lexpr@(L _ expr) = do bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body let funcPatternPartLine = docCols ColCasePattern - $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) docAlt [ -- single line docSeq @@ -313,12 +313,12 @@ layoutExpr lexpr@(L _ expr) = do $ docAddBaseY BrIndentRegular $ docPar expDocLeft - (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) + (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]) NegApp op _ -> do opDoc <- docSharedWrapper layoutExpr op - docSeq $ [ docLit $ Text.pack "-" - , opDoc - ] + docSeq [ docLit $ Text.pack "-" + , opDoc + ] HsPar innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -357,7 +357,7 @@ layoutExpr lexpr@(L _ expr) = do case splitFirstLast argDocs of FirstLastEmpty -> docSeq [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit + , docNodeAnnKW lexpr (Just AnnOpenP) closeLit ] FirstLastSingleton e -> docAlt [ docCols ColTuple @@ -382,12 +382,12 @@ layoutExpr lexpr@(L _ expr) = do addAlternative $ let start = docCols ColTuples - [appSep $ openLit, e1] + [appSep openLit, e1] linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" @@ -551,9 +551,9 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline $ bindDoc + , appSep $ docForceSingleline bindDoc , appSep $ docLit $ Text.pack "in" - , docForceSingleline $ expDoc1 + , docForceSingleline expDoc1 ] , docLines [ docAlt @@ -565,7 +565,7 @@ layoutExpr lexpr@(L _ expr) = do , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ bindDoc) + (docSetBaseAndIndent bindDoc) ] , docAlt [ docSeq @@ -575,7 +575,7 @@ layoutExpr lexpr@(L _ expr) = do , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + (docSetBaseY expDoc1) ] ] ] @@ -598,21 +598,21 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docSetBaseAndIndent $ docLines bindDocs) , docSeq [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ expDoc1 + , docAddBaseY BrIndentRegular expDoc1 ] ] addAlternativeCond (indentPolicy /= IndentPolicyLeft) $ docLines [ docSeq [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ bindDocs + , docSetBaseAndIndent $ docLines bindDocs ] , docSeq [ appSep $ docLit $ Text.pack "in " - , docSetBaseY $ expDoc1 + , docSetBaseY expDoc1 ] ] addAlternative @@ -700,7 +700,7 @@ layoutExpr lexpr@(L _ expr) = do [ docSeq [ docLit $ Text.pack "[" , docSeparator - , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e + , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e ] , docLit $ Text.pack "]" ] @@ -739,20 +739,20 @@ layoutExpr lexpr@(L _ expr) = do fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr - return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + return (fieldl, lrdrNameToText lnameF, fExpDoc) let line1 appender wrapper = [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , docWrapNodePrior fd1l $ appSep $ docLit fd1n , case fd1e of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper $ x + , docWrapNodeRest fd1l $ wrapper x ] Nothing -> docEmpty ] let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docWrapNode lfield $ docSeq [ appSep $ docLit $ Text.pack "=" @@ -766,14 +766,14 @@ layoutExpr lexpr@(L _ expr) = do ] docAlt [ docSeq - $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 id docForceSingleline ++ join (lineR docForceSingleline) ++ lineN , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing $ nameDoc) + (docNodeAnnKW lexpr Nothing nameDoc) ( docNonBottomSpacing $ docLines $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] @@ -790,20 +790,20 @@ layoutExpr lexpr@(L _ expr) = do fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr - return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + return (fieldl, lrdrNameToText lnameF, fExpDoc) let line1 appender wrapper = [ appender $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , docWrapNodePrior fd1l $ appSep $ docLit fd1n , case fd1e of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper $ x + , docWrapNodeRest fd1l $ wrapper x ] Nothing -> docEmpty ] let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docWrapNode lfield $ docSeq [ appSep $ docLit $ Text.pack "=" @@ -821,7 +821,7 @@ layoutExpr lexpr@(L _ expr) = do ] docAlt [ docSeq - $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] + $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 id docForceSingleline ++ join (lineR docForceSingleline) ++ lineDot @@ -829,7 +829,7 @@ layoutExpr lexpr@(L _ expr) = do , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing $ nameDoc) + (docNodeAnnKW lexpr Nothing nameDoc) ( docNonBottomSpacing $ docLines $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] @@ -880,7 +880,7 @@ layoutExpr lexpr@(L _ expr) = do , docSetBaseY $ docLines $ let line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , docWrapNodePrior rF1f $ appSep $ docLit rF1n , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" @@ -890,7 +890,7 @@ layoutExpr lexpr@(L _ expr) = do ] lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docSeq [ appSep $ docLit $ Text.pack "=" , docForceSingleline x @@ -913,14 +913,14 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing $ rExprDoc) + (docNodeAnnKW lexpr Nothing rExprDoc) (docNonBottomSpacing $ docLines $ let expressionWrapper = if indentPolicy == IndentPolicyLeft then docForceParSpacing else docSetBaseY line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , docWrapNodePrior rF1f $ appSep $ docLit rF1n , docWrapNodeRest rF1f $ case rF1e of Just x -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "=" @@ -934,7 +934,7 @@ layoutExpr lexpr@(L _ expr) = do lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate [ docCommaSep - , appSep $ docLit $ fText + , appSep $ docLit fText , case fDoc of Just x -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "=" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 51bb03a..d506239 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -94,14 +94,14 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat - return $ (lrdrNameToText lnameF, fExpDoc) + return (lrdrNameToText lnameF, fExpDoc) fmap Seq.singleton $ docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ List.intersperse docCommaSep $ fds <&> \case (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit $ fieldName + [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" , fieldDoc >>= colsWrapPat ] @@ -123,13 +123,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat - return $ (lrdrNameToText lnameF, fExpDoc) + return (lrdrNameToText lnameF, fExpDoc) fmap Seq.singleton $ docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ fds >>= \case (fieldName, Just fieldDoc) -> - [ appSep $ docLit $ fieldName + [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" , fieldDoc >>= colsWrapPat , docCommaSep @@ -167,7 +167,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of docAddBaseY BrIndentRegular $ docSeq [ appSep $ return xN , appSep $ docLit $ Text.pack "::" - , docForceSingleline $ tyDoc + , docForceSingleline tyDoc ] return $ xR Seq.|> xN' ListPat elems _ _ -> @@ -205,7 +205,7 @@ wrapPatPrepend wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty + Seq.EmptyL -> return Seq.empty x1 Seq.:< xR -> do x1' <- docSeq [prepElem, return x1] return $ x1' Seq.<| xR -- 2.30.2 From 226da07815eaa0cc38ab8fd7e8da031907cbaf9f Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:51:37 +0100 Subject: [PATCH 140/478] Improve vertical alignment --- .../Brittany/Internal/Layouters/Expr.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index c185482..f414b3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -106,7 +106,7 @@ layoutExpr lexpr@(L _ expr) = do #else /* ghc-8.0 */ HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do #endif - binderDoc <- docLit $ Text.pack "->" + binderDoc <- docLit $ Text.pack "->" funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") @@ -114,8 +114,8 @@ layoutExpr lexpr@(L _ expr) = do HsApp exp1@(L _ HsApp{}) exp2 -> do let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) gather list = \case - (L _ (HsApp l r)) -> gather (r:list) l - x -> (x, list) + L _ (HsApp l r) -> gather (r:list) l + x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 let colsOrSequence = case headE of L _ (HsVar (L _ (Unqual occname))) -> @@ -230,8 +230,8 @@ layoutExpr lexpr@(L _ expr) = do | xD <- docSharedWrapper layoutExpr x , yD <- docSharedWrapper layoutExpr y ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight hasComments <- hasAnyCommentsBelow lexpr let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) @@ -1090,10 +1090,10 @@ litBriDoc = \case 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 + 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 -- 2.30.2 From 545eff9e4f1448191187c795fefc29e272f2f25a Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:52:22 +0100 Subject: [PATCH 141/478] Remove redundant parens --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index f414b3c..7f0d8e9 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -137,7 +137,7 @@ layoutExpr lexpr@(L _ expr) = do , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ (docForceSingleline <$> paramDocs) + $ docForceSingleline <$> paramDocs ] -- foo -- x @@ -243,11 +243,10 @@ layoutExpr lexpr@(L _ expr) = do $ docSeq [ appSep $ docForceSingleline leftOperandDoc , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq + $ appListDocs <&> \(od, ed) -> docSeq [ appSep $ docForceSingleline od , appSep $ docForceSingleline ed ] - ) , appSep $ docForceSingleline opLastDoc , (if allowPar then docForceParSpacing else docForceSingleline) expLastDoc @@ -1056,7 +1055,7 @@ layoutExpr lexpr@(L _ expr) = do docLit $ Text.pack "_" EAsPat asName asExpr -> do docSeq - [ docLit $ (lrdrNameToText asName) <> Text.pack "@" + [ docLit $ lrdrNameToText asName <> Text.pack "@" , layoutExpr asExpr ] EViewPat{} -> do -- 2.30.2 From 631d9e181da713eee9c18a7f3bbf535dee53d925 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:52:44 +0100 Subject: [PATCH 142/478] Replace 'fmap f $' with 'f <$>' --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 2 +- .../Haskell/Brittany/Internal/Layouters/Pattern.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 7f0d8e9..a7848eb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -659,7 +659,7 @@ layoutExpr lexpr@(L _ expr) = do $ List.last stmtDocs , appSep $ docLit $ Text.pack "|" , docSeq $ List.intersperse docCommaSep - $ fmap docForceSingleline $ List.init stmtDocs + $ docForceSingleline <$> List.init stmtDocs , docLit $ Text.pack " ]" ] addAlternative $ diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index d506239..120c2b6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -95,7 +95,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return Nothing else Just <$> docSharedWrapper layoutPat fPat return (lrdrNameToText lnameF, fExpDoc) - fmap Seq.singleton $ docSeq + Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ List.intersperse docCommaSep @@ -112,7 +112,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname - fmap Seq.singleton $ docSeq + Seq.singleton <$> docSeq [ appSep $ docLit t , docLit $ Text.pack "{..}" ] @@ -124,7 +124,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return Nothing else Just <$> docSharedWrapper layoutPat fPat return (lrdrNameToText lnameF, fExpDoc) - fmap Seq.singleton $ docSeq + Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" , docSeq $ fds >>= \case @@ -193,7 +193,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- else -- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n -- endif - _ -> fmap return $ briDocByExactInlineOnly "some unknown pattern" lpat + _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList -- 2.30.2 From 7a602296734728b9a41814e394715708cf8ca2ad Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 30 Mar 2018 10:53:08 +0100 Subject: [PATCH 143/478] Fix some hlint hints --- src/Language/Haskell/Brittany/Internal/LayouterBasics.hs | 4 ++-- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 43b4b09..48730c7 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -264,8 +264,8 @@ extractAllComments ann = ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast anns = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns +filterAnns ast = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow ast@(L l _) = do diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 120c2b6..bf09e52 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -216,7 +216,7 @@ wrapPatListy -> String -> ToBriDocM (Seq BriDocNumbered) wrapPatListy elems start end = do - elemDocs <- Seq.fromList elems `forM` \e -> layoutPat e >>= colsWrapPat + elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) sDoc <- docLit $ Text.pack start eDoc <- docLit $ Text.pack end case Seq.viewl elemDocs of -- 2.30.2 From 049f286e6faa7b2bf150c986e7ce81ed0bcca6b0 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 2 Apr 2018 22:47:07 +0100 Subject: [PATCH 144/478] Add .hlint.yaml --- .hlint.yaml | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 .hlint.yaml diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..6fecf6a --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,24 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + +# Specify additional command line arguments + +- arguments: + [ "--cpp-include=srcinc" + , "--language=GADTs" + , "--language=LambdaCase" + , "--language=MultiWayIf" + , "--language=KindSignatures" + , "--cross" + , "--threads=0" + ] + +- ignore: {name: "Use camelCase"} +- ignore: {name: "Redundant as"} +- ignore: {name: "Redundant do"} +- ignore: {name: "Redundant return"} +- ignore: {name: "Redundant guard", whithin: "lrdrNameToTextAnn"} -- 2.30.2 From 9bd3bfbe4c150540ad351410879e105f649f8637 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Tue, 3 Apr 2018 22:49:06 +0100 Subject: [PATCH 145/478] Review suggestions --- .../Brittany/Internal/LayouterBasics.hs | 5 --- .../Brittany/Internal/Layouters/Decl.hs | 19 +++++----- .../Haskell/Brittany/Internal/Layouters/IE.hs | 37 ++++++++++--------- 3 files changed, 29 insertions(+), 32 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 48730c7..191581c 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -14,7 +14,6 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docLit , docAlt , CollectAltM - , addAlternativeCondM , addAlternativeCond , addAlternative , runFilteredAlternative @@ -426,10 +425,6 @@ docAlt l = allocateNode . BDFAlt =<< sequence l newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) deriving (Functor, Applicative, Monad) -addAlternativeCondM :: Bool -> CollectAltM (ToBriDocM BriDocNumbered) -> CollectAltM () -addAlternativeCondM cond doc = - addAlternativeCond cond =<< doc - addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () addAlternativeCond cond doc = when cond (addAlternative doc) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index d27c385..babcab1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -308,21 +308,22 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ++ (List.intersperse docCommaSep (docForceSingleline . return <$> gs) ) + wherePart = case mWhereDocs of + Nothing -> Just docEmpty + Just [w] -> Just $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> Nothing indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + runFilteredAlternative $ do - let wherePart = case mWhereDocs of - Nothing -> Just docEmpty - Just [w] -> Just $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> Nothing case clauseDocs of [(guards, body, _bodyRaw)] -> do let guardPart = singleLineGuardsDoc guards @@ -385,7 +386,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine - _ -> return () + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` case mPatDoc of Nothing -> return () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 61af2da..2ba66a0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -118,21 +118,22 @@ layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - case ieDs of - [] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ - docLit $ Text.pack "()" - addAlternativeCond hasComments $ - docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH:ieDsT) -> runFilteredAlternative $ do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] + runFilteredAlternative $ + case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ + docLit $ Text.pack "()" + addAlternativeCond hasComments $ + docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH:ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] -- 2.30.2 From 7ffa58976f01bcdad5de58f49746c5b1e5760016 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Tue, 3 Apr 2018 22:55:57 +0100 Subject: [PATCH 146/478] Clean up duplicate ghc-options from cabal file --- brittany.cabal | 3 --- 1 file changed, 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 7c6b574..c40c43e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -244,7 +244,6 @@ test-suite unittests , ghc-boot-th , hspec >=2.4.1 && <2.5 } - ghc-options: -Wall main-is: TestMain.hs other-modules: TestUtils AsymptoticPerfTests @@ -314,7 +313,6 @@ test-suite littests , filepath , parsec >=3.1.11 && <3.2 } - ghc-options: -Wall main-is: Main.hs other-modules: hs-source-dirs: src-literatetests @@ -355,7 +353,6 @@ test-suite libinterfacetests , transformers , hspec >=2.4.1 && <2.5 } - ghc-options: -Wall main-is: Main.hs other-modules: hs-source-dirs: src-libinterfacetests -- 2.30.2 From 62d066d49688f47e3d7af18926467eb44e7a6349 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Apr 2018 21:05:19 +0200 Subject: [PATCH 147/478] Un-ignore coreIO error-numbers when processing one file only --- src-brittany/Main.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 7538411..a48540b 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -183,9 +183,10 @@ mainCmdParser helpDesc = do trace (showConfigYaml config) $ return () results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths - case sequence_ results of - Left _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) - Right _ -> pure () + case results of + xs | all Data.Either.isRight xs -> pure () + [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) -- | The main IO parts for the default mode of operation, and after commandline -- 2.30.2 From e0e1e5038eeb612229a90b0bb854344e7f383fce Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Apr 2018 21:06:02 +0200 Subject: [PATCH 148/478] Add some stuff to .gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 758506f..906e747 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ local/ .cabal-sandbox/ .stack-work/ cabal.sandbox.config +cabal.project.local +.ghc.environment.* -- 2.30.2 From 21ef8b296c5e083c75030c5f5dd8484032ab20e6 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Apr 2018 21:06:44 +0200 Subject: [PATCH 149/478] Adapt for czipwith-1.0.1.0 --- brittany.cabal | 2 +- .../Haskell/Brittany/Internal/Config/Types.hs | 11 +++++++++-- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index c40c43e..e8f7fab 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -109,7 +109,7 @@ library { , deepseq >=1.4.2.0 && <1.5 , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 - , czipwith >=1.0.0.0 && <1.1 + , czipwith >=1.0.1.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.3 , filepath >=1.4.1.0 && <1.5 } diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index dc0300f..d28527d 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -5,6 +5,9 @@ {-# LANGUAGE DeriveDataTypeable #-} module Language.Haskell.Brittany.Internal.Config.Types + ( module Language.Haskell.Brittany.Internal.Config.Types + , cMap + ) where @@ -277,8 +280,12 @@ data ExactPrintFallbackMode -- A PROGRAM BY TRANSFORMING IT. deriving (Show, Generic, Data) -cMap :: CZipWith k => (forall a . f a -> g a) -> k f -> k g -cMap f c = cZipWith (\_ -> f) c c +instance CFunctor CDebugConfig +instance CFunctor CLayoutConfig +instance CFunctor CErrorHandlingConfig +instance CFunctor CForwardOptions +instance CFunctor CPreProcessorConfig +instance CFunctor CConfig deriveCZipWith ''CDebugConfig deriveCZipWith ''CLayoutConfig -- 2.30.2 From 8b67a028ea83666b95c43b50bc751a46057ea3c5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 9 Apr 2018 00:06:44 +0200 Subject: [PATCH 150/478] Do not put `where` on newline when no export list (even when lconfig_allowSingleLineExportList False) --- src/Language/Haskell/Brittany/Internal/Layouters/Module.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index b959b28..1b7918d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -33,13 +33,16 @@ layoutModule lmod@(L _ mod') = case mod' of <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack + -- the config should not prevent single-line layout when there is no + -- export list + let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les docLines $ docSeq [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node , docNodeMoveToKWDP lmod AnnModule $ runFilteredAlternative $ do - addAlternativeCond allowSingleLineExportList $ + addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq [ appSep $ docLit $ Text.pack "module" -- 2.30.2 From e79af18fb6a1edd61cf8a81ab90b72a9394a40d3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 9 Apr 2018 00:24:23 +0200 Subject: [PATCH 151/478] Omit file write if file is unchanged (fixes #93) --- src-brittany/Main.hs | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index a48540b..fed179b 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -247,19 +247,20 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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 + (errsWarns, outSText) <- do if exactprintOnly then do - pure ([], TextL.pack $ ExactPrint.exactPrint parsedSource anns) + pure ([], Text.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 out = TextL.toStrict $ if hackAroundIncludes + then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw + else outRaw + pure $ (ews, out) let customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = 0 :: Int customErrOrder ErrorOutputCheck{} = 1 @@ -305,8 +306,20 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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 + Nothing -> liftIO $ Text.IO.putStr $ outSText + Just p -> liftIO $ do + isIdentical <- case inputPathM of + Nothing -> pure False + Just path -> do + (== outSText) <$> Text.IO.readFile path + -- The above means we read the file twice, but the + -- GHC API does not really expose the source it + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> handle still open -> + -- write below crashes - evil.) + unless isIdentical $ Text.IO.writeFile p $ outSText when hasErrors $ ExceptT.throwE 70 where -- 2.30.2 From ae162403ae78f9cf19032892b3eb9e2e08bbd6b8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 13 Apr 2018 22:13:15 +0200 Subject: [PATCH 152/478] Support multistate-0.9 (ghc-8.4 preparation) --- brittany.cabal | 2 +- src/Language/Haskell/Brittany/Internal/Prelude.hs | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index e8f7fab..09d3ebc 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -90,7 +90,7 @@ library { , containers >=0.5.7.1 && <0.6 , mtl >=2.2.1 && <2.3 , text >=1.2 && <1.3 - , multistate >=0.7.1.1 && <0.8 + , multistate >=0.7.1.1 && <0.9 , syb >=0.6 && <0.8 , neat-interpolation >=0.3.2 && <0.4 , data-tree-print diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 646ebb7..dbd4b52 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -312,6 +312,7 @@ import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) MonadMultiReader(..) , MonadMultiWriter(..) , MonadMultiState(..) + , mGet -- , runMultiRWST -- , runMultiRWSTASW -- , runMultiRWSTW -- 2.30.2 From 213e82b47669fb2a1a945c04a72b147a05d32ba5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 06:03:15 +0200 Subject: [PATCH 153/478] Fix if-then-else paragraph layouting --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a7848eb..9116c79 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -456,13 +456,13 @@ layoutExpr lexpr@(L _ expr) = do (docLines [ docAddBaseY BrIndentRegular $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt + $ docNonBottomSpacing $ docAlt [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "then") thenExprDoc ] , docAddBaseY BrIndentRegular - $ docAlt + $ docNonBottomSpacing $ docAlt [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "else") elseExprDoc -- 2.30.2 From ad744b0247fb4aa91d3491717878c6f58b106bec Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 16:23:33 +0200 Subject: [PATCH 154/478] Fix stack.yaml --- .travis.yml | 4 ++-- stack-8.0.2.yaml | 4 ++-- stack-8.2.2.yaml | 7 +++++++ stack.yaml | 3 +++ 4 files changed, 14 insertions(+), 4 deletions(-) create mode 100644 stack-8.2.2.yaml diff --git a/.travis.yml b/.travis.yml index 50a0a71..55adf2e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -64,8 +64,8 @@ matrix: ##### OSX test via stack ##### # Build on macOS in addition to Linux - - env: BUILD=stack ARGS="" - compiler: ": #stack default osx" + - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml" + compiler: ": #stack 8.2.2 osx" os: osx ##### CABAL ##### diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index ca6ad6a..4f20ca7 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -2,11 +2,11 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - - czipwith-1.0.0.0 + - czipwith-1.0.1.0 - butcher-1.3.0.0 - data-tree-print-0.1.0.0 - deque-0.2 - ghc-exactprint-0.5.6.0 packages: - - . + - . \ No newline at end of file diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml new file mode 100644 index 0000000..899363f --- /dev/null +++ b/stack-8.2.2.yaml @@ -0,0 +1,7 @@ +resolver: lts-11.1 + +extra-deps: + - czipwith-1.0.1.0 + +packages: + - . diff --git a/stack.yaml b/stack.yaml index 44e8d17..899363f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,7 @@ resolver: lts-11.1 +extra-deps: + - czipwith-1.0.1.0 + packages: - . -- 2.30.2 From 3785d15c2a38dc38b8693607666ddb06ead7e318 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 15 Apr 2018 23:45:17 +0200 Subject: [PATCH 155/478] Bump some upper bounds, Remove unneeded dep --- brittany.cabal | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 09d3ebc..bee2b04 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -174,7 +174,6 @@ executable brittany , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.5 , filepath >=1.4.1.0 && <1.5 } hs-source-dirs: src-brittany @@ -242,7 +241,7 @@ test-suite unittests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.5 + , hspec >=2.4.1 && <2.6 } main-is: TestMain.hs other-modules: TestUtils @@ -309,7 +308,7 @@ test-suite littests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.5 + , hspec >=2.4.1 && <2.6 , filepath , parsec >=3.1.11 && <3.2 } @@ -351,7 +350,7 @@ test-suite libinterfacetests , base , text , transformers - , hspec >=2.4.1 && <2.5 + , hspec >=2.4.1 && <2.6 } main-is: Main.hs other-modules: -- 2.30.2 From ac76b691278899feed16a6047a880b9a44e4d225 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 17:08:21 +0200 Subject: [PATCH 156/478] Permit stack.yaml failure in travis --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 55adf2e..2223ff3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -148,6 +148,7 @@ matrix: allow_failures: #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=stack ARGS="--resolver nightly" + - env: BUILD=stack ARGS="" before_install: # Using compiler above sets CC to an invalid value, so unset it -- 2.30.2 From 10e1c19788aeb8089d0df7814c6b49769da9c2c9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 17:00:55 +0200 Subject: [PATCH 157/478] Add support for ghc-8.4 --- .travis.yml | 24 +++--- brittany.cabal | 6 +- src/Language/Haskell/Brittany/Internal.hs | 11 ++- .../Haskell/Brittany/Internal/Config.hs | 3 +- .../Brittany/Internal/ExactPrintUtils.hs | 20 +++-- .../Brittany/Internal/Layouters/Decl.hs | 78 +++++++++++-------- .../Brittany/Internal/Layouters/Expr.hs | 42 ++++++++-- .../Brittany/Internal/Layouters/Expr.hs-boot | 7 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 5 +- .../Brittany/Internal/Layouters/Import.hs | 1 - .../Brittany/Internal/Layouters/Module.hs | 1 - .../Brittany/Internal/Layouters/Pattern.hs | 7 +- .../Brittany/Internal/Layouters/Stmt.hs | 3 +- .../Brittany/Internal/Layouters/Stmt.hs-boot | 3 +- .../Brittany/Internal/Layouters/Type.hs | 1 - .../Haskell/Brittany/Internal/Prelude.hs | 25 +++++- .../Haskell/Brittany/Internal/Types.hs | 7 +- 17 files changed, 159 insertions(+), 85 deletions(-) diff --git a/.travis.yml b/.travis.yml index 2223ff3..46b2763 100644 --- a/.travis.yml +++ b/.travis.yml @@ -73,9 +73,12 @@ matrix: - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.2.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.2.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.2.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.4.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.4.1" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. @@ -85,15 +88,15 @@ matrix: ##### CABAL DIST CHECK - - env: BUILD=cabaldist GHCVER=8.2.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.2.1 dist" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabaldist GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.2.2 dist" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} ##### CANEW ##### - - env: BUILD=canew GHCVER=8.2.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal new 8.2.1" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=canew GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal new 8.2.2" + addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} ##### STACK ##### @@ -118,6 +121,9 @@ matrix: - env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml" compiler: ": #stack 8.0.2" addons: {apt: {packages: [libgmp-dev]}} + - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml" + compiler: ": #stack 8.2.2" + addons: {apt: {packages: [libgmp-dev]}} # Nightly builds are allowed to fail - env: BUILD=stack ARGS="--resolver nightly" diff --git a/brittany.cabal b/brittany.cabal index bee2b04..d734dc2 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -82,8 +82,8 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.9 && <4.11 - , ghc >=8.0.1 && <8.3 + { base >=4.9 && <4.12 + , ghc >=8.0.1 && <8.5 , ghc-paths >=0.1.0.9 && <0.2 , ghc-exactprint >=0.5.6.0 && <0.5.7 , transformers >=0.5.2.0 && <0.6 @@ -110,7 +110,7 @@ library { , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.0.1 && <8.3 + , ghc-boot-th >=8.0.1 && <8.5 , filepath >=1.4.1.0 && <1.5 } default-extensions: { diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e6a3c72..eb57aa4 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -47,7 +47,6 @@ import Language.Haskell.Brittany.Internal.Transformations.Indent import qualified GHC as GHC hiding (parseModule) import ApiAnnotation ( AnnKeywordId(..) ) -import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import SrcLoc ( SrcSpan ) import HsSyn @@ -248,7 +247,7 @@ parsePrintModuleTests conf filename input = do -- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- else return $ TextL.toStrict $ Text.Builder.toLazyText out -ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () +ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM () ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do @@ -302,7 +301,7 @@ withTransformedAnns ast m = do in annsBalanced -ppDecl :: LHsDecl RdrName -> PPMLocal () +ppDecl :: LHsDecl GhcPs -> PPMLocal () ppDecl d@(L loc decl) = case decl of SigD sig -> -- trace (_sigHead sig) $ withTransformedAnns d $ do @@ -322,7 +321,7 @@ ppDecl d@(L loc decl) = case decl of -- Prints the information associated with the module annotation -- This includes the imports -ppPreamble :: GenLocated SrcSpan (HsModule RdrName) +ppPreamble :: GenLocated SrcSpan (HsModule GhcPs) -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> @@ -390,13 +389,13 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule return post -_sigHead :: Sig RdrName -> String +_sigHead :: Sig GhcPs -> String _sigHead = \case TypeSig names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) _ -> "unknown sig" -_bindHead :: HsBind RdrName -> String +_bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _pat _ _ _ ([], []) -> "PatBind smth" diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 76e9c95..2719e82 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -38,6 +38,7 @@ import Language.Haskell.Brittany.Internal.Config.Types.Instances import Language.Haskell.Brittany.Internal.Utils import Data.Coerce ( Coercible, coerce ) +import qualified Data.List.NonEmpty as NonEmpty import qualified System.Directory as Directory import qualified System.FilePath.Posix as FilePath @@ -272,7 +273,7 @@ readConfigs -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let merged = Semigroup.mconcat $ reverse (cmdlineConfig:catMaybes configs) + let merged = Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 749804c..19bc835 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -29,10 +29,9 @@ import qualified GHC as GHC hiding (parseModule) import qualified Lexer as GHC import qualified StringBuffer as GHC import qualified Outputable as GHC -import RdrName ( RdrName(..) ) +import qualified CmdLineParser as GHC import HsSyn import SrcLoc ( SrcSpan, Located ) -import RdrName ( RdrName(..) ) import qualified Language.Haskell.GHC.ExactPrint as ExactPrint @@ -79,7 +78,7 @@ parseModuleWithCpp cpp opts args fp dynCheck = when (not $ null warnings) $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " - ++ show (warnings <&> \(L _ s) -> s) + ++ show (warnings <&> warnExtractorCompat) x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) @@ -111,7 +110,7 @@ parseModuleFromString args fp dynCheck str = when (not $ null warnings) $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " - ++ show (warnings <&> \(L _ s) -> s) + ++ show (warnings <&> warnExtractorCompat) dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of @@ -187,7 +186,7 @@ commentAnnFixTransform modul = SYB.everything (>>) genF modul where genF :: Data.Data.Data a => a -> ExactPrint.Transform () genF = (\_ -> return ()) `SYB.extQ` exprF - exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform () + exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () exprF lexpr@(L _ expr) = case expr of RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) -> moveTrailingComments lexpr (List.last fs) @@ -226,7 +225,7 @@ moveTrailingComments astFrom astTo = do -- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- implementation would have. extractToplevelAnns - :: Located (HsModule RdrName) + :: Located (HsModule GhcPs) -> ExactPrint.Anns -> Map ExactPrint.AnnKey ExactPrint.Anns extractToplevelAnns lmod anns = output @@ -265,3 +264,12 @@ foldedAnnKeys ast = SYB.everything ) ast where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) + + +#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ +warnExtractorCompat :: GHC.Warn -> String +warnExtractorCompat (GHC.Warn _ (L _ s)) = s +#else /* ghc-8.0 && ghc-8.2 */ +warnExtractorCompat :: GenLocated l String -> String +warnExtractorCompat (L _ s) = s +#endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index babcab1..53f58b7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -20,7 +20,6 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import SrcLoc ( SrcSpan ) import HsSyn @@ -88,11 +87,7 @@ layoutSig lsig@(L _loc sig) = case sig of InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name - let specStr = case spec of - Inline -> "INLINE " - Inlinable -> "INLINABLE " - NoInline -> "NOINLINE " - EmptyInlineSpec -> "" -- i have no idea if this is correct. + specStr <- specStringCompat lsig spec let phaseStr = case phaseAct of NeverActive -> "" -- not [] - for NOINLINE NeverActive is -- in fact the default @@ -108,7 +103,23 @@ layoutSig lsig@(L _loc sig) = case sig of <> Text.pack " #-}" _ -> briDocByExactNoComment lsig -- TODO -layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName)) +specStringCompat + :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String +#if MIN_VERSION_ghc(8,4,0) +specStringCompat ast = \case + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " +#else +specStringCompat _ = \case + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " + EmptyInlineSpec -> pure "" +#endif + +layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of BodyStmt body _ _ _ -> layoutExpr body BindStmt lPat expr _ _ _ -> do @@ -122,7 +133,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of layoutBind :: ToBriDocC - (HsBindLR RdrName RdrName) + (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do @@ -148,15 +159,15 @@ layoutBind lbind@(L _ bind) = case bind of hasComments _ -> Right <$> unknownNodeError "" lbind -data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName) - | BagSig (LSig RdrName) +data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) + | BagSig (LSig GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds - :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered]) + :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) layoutLocalBinds lbinds@(L _ binds) = case binds of -- HsValBinds (ValBindsIn lhsBindsLR []) -> -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering @@ -178,11 +189,11 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x EmptyLocalBinds -> return $ Nothing --- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is +-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- parSpacing stuff.B layoutGrhs - :: LGRHS RdrName (LHsExpr RdrName) - -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName) + :: LGRHS GhcPs (LHsExpr GhcPs) + -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) layoutGrhs lgrhs@(L _ (GRHS guards body)) = do guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body @@ -191,12 +202,14 @@ layoutGrhs lgrhs@(L _ (GRHS guards body)) = do layoutPatternBind :: Maybe Text -> BriDocNumbered - -> LMatch RdrName (LHsExpr RdrName) + -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered -layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do +layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do + let pats = m_pats match + let (GRHSs grhss whereBinds) = m_grhss match patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match - let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr + let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of (Just idStr, p1 : pr) | isInfix -> docCols ColPatternsFuncInfix @@ -222,25 +235,26 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ ( mWhereDocs hasComments -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 && ghc-8.4 */ fixPatternBindIdentifier - :: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text -fixPatternBindIdentifier ctx idStr = case ctx of - (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr - (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1 ) -> fixPatternBindIdentifier' ctx1 - _ -> idStr + :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier match idStr = go $ m_ctxt match where + go = \case + (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr + (FunRhs _ _ NoSrcStrict) -> idStr + (StmtCtxt ctx1 ) -> goInner ctx1 + _ -> idStr -- I have really no idea if this path ever occurs, but better safe than -- risking another "drop bangpatterns" bugs. - fixPatternBindIdentifier' = \case - (PatGuard ctx1) -> fixPatternBindIdentifier ctx1 idStr - (ParStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 - (TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 + goInner = \case + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 + (TransStmtCtxt ctx1) -> goInner ctx1 _ -> idStr -#else /* ghc-8.0 */ -fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text +#else /* ghc-8.0 */ +fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier _ x = x #endif @@ -248,7 +262,7 @@ layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered - -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] + -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] -> Maybe [BriDocNumbered] -> Bool -> ToBriDocM BriDocNumbered diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 9116c79..93a06ac 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -15,8 +15,7 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import RdrName ( RdrName(..) ) -import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..), RdrName(..) ) import HsSyn import Name import qualified FastString @@ -56,7 +55,12 @@ layoutExpr lexpr@(L _ expr) = do allocateNode $ overLitValBriDoc olit HsLit lit -> do allocateNode $ litBriDoc lit - HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do + HsLam (MG (L _ [lmatch@(L _ match)]) _ _ _) + | pats <- m_pats match + , GRHSs [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds <- llocals + , L _ (GRHS [] body) <- lgrhs + -> do patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body let funcPatternPartLine = @@ -112,7 +116,7 @@ layoutExpr lexpr@(L _ expr) = do (docLit $ Text.pack "\\case") (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) HsApp exp1@(L _ HsApp{}) exp2 -> do - let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) + let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) gather list = \case L _ (HsApp l r) -> gather (r:list) l x -> (x, list) @@ -220,7 +224,7 @@ layoutExpr lexpr@(L _ expr) = do -- TODO briDocByExactInlineOnly "HsAppTypeOut{}" lexpr OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do - let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)]) + let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) gather opExprList = \case (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 final -> (final, opExprList) @@ -1077,7 +1081,31 @@ layoutExpr lexpr@(L _ expr) = do #endif -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ +litBriDoc :: HsLit GhcPs -> BriDocFInt +litBriDoc = \case + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + _ -> error "litBriDoc: literal with no SourceText" + +overLitValBriDoc :: OverLitVal -> BriDocFInt +overLitValBriDoc = \case + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIsString (SourceText t) _ -> BDFLit $ Text.pack t + _ -> error "overLitValBriDoc: literal with no SourceText" +#elif 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, '\''] @@ -1101,7 +1129,7 @@ overLitValBriDoc = \case HsFractional (FL t _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" -#else +#else /* ghc-8.0 */ litBriDoc :: HsLit -> BriDocFInt litBriDoc = \case HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 0d01034..1f76032 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -14,7 +14,6 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import HsSyn import Name @@ -23,8 +22,12 @@ import Name layoutExpr :: ToBriDoc HsExpr --- layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) +-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) +#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ +litBriDoc :: HsLit GhcPs -> BriDocFInt +#else /* ghc-8.0 && ghc-8.2 */ litBriDoc :: HsLit -> BriDocFInt +#endif overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 2ba66a0..4e5af9f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -11,7 +11,6 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import RdrName (RdrName(..)) import GHC ( unLoc , runGhc , GenLocated(L) @@ -89,7 +88,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered] + :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] let ieDocs = layoutIE <$> lies @@ -114,7 +113,7 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 7eb3e27..3f56dcd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -7,7 +7,6 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Config.Types -import RdrName ( RdrName(..) ) import GHC ( unLoc , GenLocated(L) , moduleNameString diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 1b7918d..2eebd20 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -8,7 +8,6 @@ import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Config.Types -import RdrName (RdrName(..)) import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) import HsSyn import Name diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index bf09e52..c65b357 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -13,7 +13,6 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import RdrName ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import HsSyn import Name @@ -34,7 +33,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type -- ^^^^^^^^^^ this part -- We will use `case .. of` as the imagined prefix to the examples used in -- the different cases below. -layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered) +layoutPat :: ToBriDocC (Pat GhcPs) (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr @@ -199,7 +198,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend - :: Located (Pat RdrName) + :: Located (Pat GhcPs) -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do @@ -211,7 +210,7 @@ wrapPatPrepend pat prepElem = do return $ x1' Seq.<| xR wrapPatListy - :: [Located (Pat RdrName)] + :: [Located (Pat GhcPs)] -> String -> String -> ToBriDocM (Seq BriDocNumbered) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 4128aea..70daf6c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -13,7 +13,6 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import HsSyn import Name @@ -26,7 +25,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) +layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt lstmt@(L _ stmt) = do indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack docWrapNode lstmt $ case stmt of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 0cb46be..faf583a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -12,7 +12,6 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import HsSyn import Name @@ -21,4 +20,4 @@ import BasicTypes -layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) +layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 646f986..dfde7f5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -13,7 +13,6 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import RdrName ( RdrName(..) ) import GHC ( runGhc , GenLocated(L) , moduleNameString diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index dbd4b52..2d8a038 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,8 +1,24 @@ -module Language.Haskell.Brittany.Internal.Prelude (module E) +module Language.Haskell.Brittany.Internal.Prelude + ( module E + , module Language.Haskell.Brittany.Internal.Prelude + ) where +-- rather project-specific stuff: +--------------------------------- +#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ +import HsExtension as E ( GhcPs ) +#endif + +import RdrName as E ( RdrName ) + + + +-- more general: +---------------- + import Data.Functor.Identity as E ( Identity(..) ) import Control.Concurrent.Chan as E ( Chan ) import Control.Concurrent.MVar as E ( MVar ) @@ -379,3 +395,10 @@ import Control.Monad.Trans.Maybe as E ( MaybeT (..) import Data.Data as E ( toConstr ) +todo :: a +todo = error "todo" + + +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +type GhcPs = RdrName +#endif diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 1d26b73..9bea756 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -16,7 +16,6 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Data.Text.Lazy.Builder as Text.Builder -import RdrName ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId ) import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) @@ -190,9 +189,9 @@ data BrIndent = BrIndentNone type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex] -type ToBriDoc (sym :: * -> *) = Located (sym RdrName) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c +type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = Located sym -> ToBriDocM c data DocMultiLine = MultiLineNo -- 2.30.2 From e559a2cbf71d58b8f1c1fe868680004cb8a54506 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 1 Oct 2017 16:16:43 +0200 Subject: [PATCH 158/478] Implement inline configuration e.g. "-- brittany --indent=4" respects the following comment forms as input: source comment affected target ====================================================== "-- brittany CONFIG" whole module "-- brittany-next-binding CONFIG" next binding "-- brittany-disable-next-binding" next binding "-- brittany @ myExampleFunc CONFIG" `myExampleFunc` multiline-comments are supported too, although the specification must still be a single line. E.g. "{- brittany --columns 50 -}" CONFIG is either: 1) one or more flags in the form of what brittany accepts on the commandline, e.g. "-- columns 50", or 2) one or more specifications in the form of what brittany accepts in its config files for the layouting config (a one-line yaml document), e.g. "{ lconfig_cols: 50 }" see #30 --- brittany.cabal | 3 +- src-brittany/Main.hs | 31 +- src/Language/Haskell/Brittany/Internal.hs | 285 +++++++++++++++--- .../Haskell/Brittany/Internal/Config.hs | 6 +- .../Haskell/Brittany/Internal/Config/Types.hs | 10 + .../Haskell/Brittany/Internal/PreludeUtils.hs | 13 +- .../Haskell/Brittany/Internal/Types.hs | 17 +- 7 files changed, 303 insertions(+), 62 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index bee2b04..4d99213 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -80,6 +80,7 @@ library { -Wall -fno-warn-unused-imports -fno-warn-redundant-constraints + -j } build-depends: { base >=4.9 && <4.11 @@ -97,7 +98,7 @@ library { , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4 - , butcher >=1.3 && <1.4 + , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 , extra >=1.4.10 && <1.7 diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index fed179b..ff7fedc 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -133,7 +133,7 @@ mainCmdParser helpDesc = do printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- configParser + cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] @@ -179,7 +179,7 @@ mainCmdParser helpDesc = do config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x - when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ + when (config & _conf_debug & _dconf_dump_config & confUnpack) $ trace (showConfigYaml config) $ return () results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths @@ -211,9 +211,11 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx -- 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 + -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- "#include" before processing (parsing) input; and remove that marker -- string from the transformation output. + -- The flag is intentionally misspelled to prevent clashing with + -- inline-config stuff. let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack let exactprintOnly = config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags @@ -232,7 +234,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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 hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s let hackTransform = if hackAroundIncludes && not exactprintOnly then List.intercalate "\n" . fmap hackF . lines' else id inputString <- liftIO $ System.IO.hGetContents System.IO.stdin @@ -244,6 +246,15 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx putErrorLn $ show left ExceptT.throwE 60 Right (anns, parsedSource, hasCPP) -> do + inlineConf <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of + Left (err, input) -> do + putErrorLn + $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + ExceptT.throwE 61 + Right c -> -- trace (showTree c) $ + pure c when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () @@ -254,9 +265,9 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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 + then return $ pPrintModule config inlineConf anns parsedSource + else liftIO $ pPrintModuleAndCheck config inlineConf anns parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s let out = TextL.toStrict $ if hackAroundIncludes then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw else outRaw @@ -266,6 +277,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 when (not $ null errsWarns) $ do let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns groupedErrsWarns `forM_` \case @@ -296,6 +308,11 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx unused `forM_` \case ErrorUnusedComment str -> putErrorLn str _ -> error "cannot happen (TM)" + (ErrorMacroConfig err input:_) -> do + putErrorLn + $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." [] -> error "cannot happen" -- TODO: don't output anything when there are errors unless user -- adds some override? diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e6a3c72..b4a4525 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -8,6 +8,8 @@ module Language.Haskell.Brittany.Internal -- re-export from utils: , parseModule , parseModuleFromString + , extractCommentConfigs + , getTopLevelDeclNameMap ) where @@ -22,7 +24,10 @@ import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data import Control.Monad.Trans.Except import Data.HList.HList +import qualified Data.Yaml +import qualified Data.ByteString.Char8 import Data.CZipWith +import qualified UI.Butcher.Monadic as Butcher import qualified Data.Text.Lazy.Builder as Text.Builder @@ -54,6 +59,170 @@ import HsSyn import qualified DynFlags as GHC import qualified GHC.LanguageExtensions.Type as GHC +import Data.Char (isSpace) + + + +data InlineConfigTarget + = InlineConfigTargetModule + | InlineConfigTargetNextDecl -- really only next in module + | InlineConfigTargetNextBinding -- by name + | InlineConfigTargetBinding String + +extractCommentConfigs + :: ExactPrint.Anns + -> TopLevelDeclNameMap + -> Either (String, String) InlineConfig +extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do + let + commentLiness = + [ ( k + , [ x + | (ExactPrint.Comment x _ _, _) <- + ( ExactPrint.annPriorComments ann + ++ ExactPrint.annFollowingComments ann + ) + ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] + ) + | (k, ann) <- Map.toList anns + ] + let configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + ( ("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) + let + configParser = Butcher.addAlternatives + [ ( "commandline-config" + , \s -> "-" `isPrefixOf` dropWhile (== ' ') s + , cmdlineConfigParser + ) + , ( "yaml-config-document" + , \s -> "{" `isPrefixOf` dropWhile (== ' ') s + , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") + $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) + . Data.Yaml.decode + . Data.ByteString.Char8.pack + -- TODO: use some proper utf8 encoder instead? + ) + ] + parser = do -- we will (mis?)use butcher here to parse the inline config + -- line. + let nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + Butcher.addCmd "-next-declaration" nextDecl + Butcher.addCmd "-Next-Declaration" nextDecl + Butcher.addCmd "-NEXT-DECLARATION" nextDecl + let nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + Butcher.addCmd "-next-binding" nextBinding + Butcher.addCmd "-Next-Binding" nextBinding + Butcher.addCmd "-NEXT-BINDING" nextBinding + let + disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty + { _conf_debug = + mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } + } + ) + Butcher.addCmd "-disable-next-binding" disableNextBinding + Butcher.addCmd "-Disable-Next-Binding" disableNextBinding + Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding + let + disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty + { _conf_debug = + mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } + } + ) + Butcher.addCmd "-disable-next-declaration" disableNextDecl + Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl + Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + Butcher.addCmd "@" $ do + -- Butcher.addCmd "module" $ do + -- conf <- configParser + -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) + Butcher.addNullCmd $ do + bindingName <- Butcher.addParamString "BINDING" mempty + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetModule, conf) + lineConfigss <- configLiness `forM` \(k, ss) -> do + r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of + Left err -> Left $ (err, s) + Right c -> Right $ c + pure (k, r) + + let perModule = foldl' + (<>) + mempty + [ conf + | (_ , lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf ) <- lineConfigs + ] + let + perBinding = Map.fromListWith + (<>) + [ (n, conf) + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , n <- case target of + InlineConfigTargetBinding s -> [s] + InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> + [name] + _ -> [] + ] + let + perKey = Map.fromListWith + (<>) + [ (k, conf) + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , case target of + InlineConfigTargetNextDecl -> True + InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> + True + _ -> False + ] + + pure $ InlineConfig + { _icd_perModule = perModule + , _icd_perBinding = perBinding + , _icd_perKey = perKey + } + + +getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap +getTopLevelDeclNameMap (L _ (HsModule _name _exports _ decls _ _)) = + TopLevelDeclNameMap $ Map.fromList + [ (ExactPrint.mkAnnKey decl, name) + | decl <- decls + , (name : _) <- [getDeclBindingNames decl] + ] -- | Exposes the transformation in an pseudo-pure fashion. The signature @@ -68,15 +237,16 @@ import qualified GHC.LanguageExtensions.Type as GHC -- may wish to put some proper upper bound on the input's size as a timeout -- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) -parsePrintModule configRaw inputText = runExceptT $ do - let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } +parsePrintModule configWithDebugs inputText = runExceptT $ do + let config = + configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let config_pp = config & _conf_preprocessor let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack (anns, parsedSource, hasCPP) <- do let hackF s = if "#include" `isPrefixOf` s - then "-- BRITTANY_INCLUDE_HACK " ++ s + then "-- BRITANY_INCLUDE_HACK " ++ s else s let hackTransform = if hackAroundIncludes then List.intercalate "\n" . fmap hackF . lines' @@ -95,6 +265,8 @@ parsePrintModule configRaw inputText = runExceptT $ do case parseResult of Left err -> throwE [ErrorInput err] Right x -> pure x + inlineConf <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure + $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) (errsWarns, outputTextL) <- do let omitCheck = config @@ -102,10 +274,10 @@ parsePrintModule configRaw inputText = runExceptT $ do & _econf_omit_output_valid_check & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config anns parsedSource - else lift $ pPrintModuleAndCheck config anns parsedSource + then return $ pPrintModule config inlineConf anns parsedSource + else lift $ pPrintModuleAndCheck config inlineConf anns parsedSource let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews @@ -119,6 +291,7 @@ parsePrintModule configRaw inputText = runExceptT $ do customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) @@ -133,10 +306,11 @@ parsePrintModule configRaw inputText = runExceptT $ do -- can occur. pPrintModule :: Config + -> InlineConfig -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) -pPrintModule conf anns parsedModule = +pPrintModule conf inlineConf anns parsedModule = let ((out, errs), debugStrings) = runIdentity @@ -146,6 +320,7 @@ pPrintModule conf anns parsedModule = $ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ do traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations @@ -169,12 +344,13 @@ pPrintModule conf anns parsedModule = -- if it does not. pPrintModuleAndCheck :: Config + -> InlineConfig -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) -pPrintModuleAndCheck conf anns parsedModule = do +pPrintModuleAndCheck conf inlineConf anns parsedModule = do let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity - let (errs, output) = pPrintModule conf anns parsedModule + let (errs, output) = pPrintModule conf inlineConf anns parsedModule parseResult <- parseModuleFromString ghcOptions "output" (\_ -> return $ Right ()) @@ -193,28 +369,34 @@ parsePrintModuleTests conf filename input = do parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of Left (_ , s ) -> return $ Left $ "parsing error: " ++ s - Right (anns, parsedModule) -> do + Right (anns, parsedModule) -> runExceptT $ do + inlineConf <- + case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x let omitCheck = conf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (errs, ltext) <- if omitCheck - then return $ pPrintModule conf anns parsedModule - else pPrintModuleAndCheck conf anns parsedModule - return $ if null errs - then Right $ TextL.toStrict $ ltext + then return $ pPrintModule conf inlineConf anns parsedModule + else lift $ pPrintModuleAndCheck conf inlineConf anns parsedModule + if null errs + then pure $ TextL.toStrict $ ltext else - let errStrs = errs <&> \case - ErrorInput str -> str - ErrorUnusedComment str -> str - LayoutWarning str -> str - ErrorUnknownNode str _ -> str - ErrorOutputCheck -> "Output is not syntactically valid." - in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs + let + errStrs = errs <&> \case + ErrorInput str -> str + ErrorUnusedComment str -> str + LayoutWarning str -> str + ErrorUnknownNode str _ -> str + ErrorMacroConfig str _ -> "when parsing inline config: " ++ str + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs --- this approach would for with there was a pure GHC.parseDynamicFilePragma. +-- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally -- pure interface. @@ -248,12 +430,25 @@ parsePrintModuleTests conf filename input = do -- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- else return $ TextL.toStrict $ Text.Builder.toLazyText out +toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a +toLocal conf anns m = do + (x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m + MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w <> write) + pure x + ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do - filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap + let declAnnKey = ExactPrint.mkAnnKey decl + let declBindingNames = getDeclBindingNames decl + inlineConf <- mAsk + let inlineModConf = _icd_perModule inlineConf + let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf + let mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk + <&> \annMap -> Map.findWithDefault Map.empty declAnnKey annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations @@ -261,13 +456,14 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do config <- mAsk - MultiRWSS.withoutMultiReader $ do - MultiRWSS.mPutRawR $ config :+: filteredAnns :+: HNil - ppDecl decl + let config' = cZipWith fromOptionIdentity config $ mconcat + (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) + + toLocal config' filteredAnns $ ppDecl decl let finalComments = filter - ( fst .> \case + (fst .> \case ExactPrint.AnnComment{} -> True - _ -> False + _ -> False ) post post `forM_` \case @@ -275,17 +471,15 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let - folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm - | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm - -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in - ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () @@ -302,6 +496,13 @@ withTransformedAnns ast m = do in annsBalanced +getDeclBindingNames :: LHsDecl RdrName -> [String] +getDeclBindingNames (L _ decl) = case decl of + SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) + ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n] + _ -> [] + + ppDecl :: LHsDecl RdrName -> PPMLocal () ppDecl d@(L loc decl) = case decl of SigD sig -> -- trace (_sigHead sig) $ @@ -380,9 +581,7 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do $ annsDoc filteredAnns' if shouldReformatPreamble - then MultiRWSS.withoutMultiReader $ do - MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil - withTransformedAnns lmod $ do + then toLocal config filteredAnns' $ withTransformedAnns lmod $ do briDoc <- briDocMToPPM $ layoutModule lmod layoutBriDoc briDoc else diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 76e9c95..6e87813 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -5,7 +5,7 @@ module Language.Haskell.Brittany.Internal.Config , DebugConfig , LayoutConfig , Config - , configParser + , cmdlineConfigParser , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig @@ -108,8 +108,8 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions ] } -configParser :: CmdParser Identity out (CConfig Option) -configParser = do +cmdlineConfigParser :: CmdParser Identity out (CConfig Option) +cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index d28527d..1da457e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -176,6 +176,16 @@ deriving instance Data (CForwardOptions Identity) deriving instance Data (CPreProcessorConfig Identity) deriving instance Data (CConfig Identity) +#if MIN_VERSION_ghc(8,2,0) +-- these instances break on earlier ghcs +deriving instance Data (CDebugConfig Option) +deriving instance Data (CLayoutConfig Option) +deriving instance Data (CErrorHandlingConfig Option) +deriving instance Data (CForwardOptions Option) +deriving instance Data (CPreProcessorConfig Option) +deriving instance Data (CConfig Option) +#endif + instance Semigroup.Semigroup (CDebugConfig Option) where (<>) = gmappend instance Semigroup.Semigroup (CLayoutConfig Option) where diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs index 88f2894..df80168 100644 --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -32,13 +32,12 @@ instance Alternative Strict.Maybe where 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 +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 (<$!>) diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 1d26b73..a0716da 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -13,6 +13,7 @@ where #include "prelude.inc" import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Data.Text.Lazy.Builder as Text.Builder @@ -28,8 +29,17 @@ import Data.Generics.Uniplate.Direct as Uniplate +data InlineConfig = InlineConfig + { _icd_perModule :: CConfig Option + , _icd_perBinding :: Map String (CConfig Option) + , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option) + } +#if MIN_VERSION_ghc(8,2,0) + deriving Data.Data.Data +#endif + type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, Config, ExactPrint.Anns] + '[Map ExactPrint.AnnKey ExactPrint.Anns, InlineConfig, Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] @@ -38,6 +48,8 @@ type PPMLocal = MultiRWSS.MultiRWS '[Text.Builder.Builder, [BrittanyError], Seq String] '[] +newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) + data LayoutState = LayoutState { _lstate_baseYs :: [Int] -- ^ stack of number of current indentation columns @@ -119,6 +131,9 @@ data BrittanyError -- ^ parsing failed | ErrorUnusedComment String -- ^ internal error: some comment went missing + | ErrorMacroConfig String String + -- ^ in-source config string parsing error; first argument is the parser + -- output and second the corresponding, ill-formed input. | LayoutWarning String -- ^ some warning | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast -- 2.30.2 From 2a8a752a595b6cac51dad2130ba17720f5be2044 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 19:52:22 +0200 Subject: [PATCH 159/478] Fix stack.yamls --- stack-8.0.2.yaml | 2 +- stack-8.2.2.yaml | 1 + stack.yaml | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index 4f20ca7..bdf7c39 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,7 +3,7 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.1.0 - - butcher-1.3.0.0 + - butcher-1.3.1.0 - data-tree-print-0.1.0.0 - deque-0.2 - ghc-exactprint-0.5.6.0 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index 899363f..cbeba2e 100644 --- a/stack-8.2.2.yaml +++ b/stack-8.2.2.yaml @@ -2,6 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 + - butcher-1.3.1.0 packages: - . diff --git a/stack.yaml b/stack.yaml index 899363f..cbeba2e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 + - butcher-1.3.1.0 packages: - . -- 2.30.2 From 17fb271694d5d2936564776f804918fabf1cb730 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 20:34:11 +0200 Subject: [PATCH 160/478] Fix inlineconfig additions for ghc-8.4 + compat The semigroup changes are a bit confusing when aiming for backwards-compat. --- src/Language/Haskell/Brittany/Internal.hs | 4 ++-- stack-8.0.2.yaml | 2 +- stack-8.2.2.yaml | 2 +- stack.yaml | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index d839fa3..7e73081 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -432,7 +432,7 @@ parsePrintModuleTests conf filename input = do toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a toLocal conf anns m = do (x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m - MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w <> write) + MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) pure x ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM () @@ -495,7 +495,7 @@ withTransformedAnns ast m = do in annsBalanced -getDeclBindingNames :: LHsDecl RdrName -> [String] +getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n] diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index bdf7c39..849e301 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,7 +3,7 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.1.0 - - butcher-1.3.1.0 + - butcher-1.3.1.1 - data-tree-print-0.1.0.0 - deque-0.2 - ghc-exactprint-0.5.6.0 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index cbeba2e..b7f4c2b 100644 --- a/stack-8.2.2.yaml +++ b/stack-8.2.2.yaml @@ -2,7 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 - - butcher-1.3.1.0 + - butcher-1.3.1.1 packages: - . diff --git a/stack.yaml b/stack.yaml index cbeba2e..b7f4c2b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 - - butcher-1.3.1.0 + - butcher-1.3.1.1 packages: - . -- 2.30.2 From 18704e403f6164aab15e7036d07ecbf27dea8c47 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Apr 2018 17:03:59 +0200 Subject: [PATCH 161/478] Fix inline disabling of brittany --- src-brittany/Main.hs | 3 +- src-literatetests/Main.hs | 15 ++++---- src-unittests/TestUtils.hs | 15 ++++---- src/Language/Haskell/Brittany/Internal.hs | 34 ++++++++----------- .../Haskell/Brittany/Internal/Config.hs | 5 ++- .../Haskell/Brittany/Internal/Config/Types.hs | 5 +++ .../Internal/Config/Types/Instances.hs | 1 + 7 files changed, 41 insertions(+), 37 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index ff7fedc..3b6f0b2 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -217,7 +217,8 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx -- The flag is intentionally misspelled to prevent clashing with -- inline-config stuff. let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + let exactprintOnly = (config & _conf_roundtrip_exactprint_only & confUnpack) + || (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack) let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags then case cppMode of CPPModeAbort -> do diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index ebe2a08..42e4c19 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -160,9 +160,9 @@ instance Show PPTextWrapper where defaultTestConfig :: Config defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig { _lconfig_cols = coerce (80 :: Int) , _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentAmount = coerce (2 :: Int) @@ -178,13 +178,12 @@ defaultTestConfig = Config , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } - , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } + , _conf_preprocessor = _conf_preprocessor staticDefaultConfig + , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_roundtrip_exactprint_only = coerce True } contextFreeTestConfig :: Config diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index d10f85a..c14b3b8 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -42,9 +42,9 @@ instance Show PPTextWrapper where defaultTestConfig :: Config defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig { _lconfig_cols = coerce (80 :: Int) , _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentAmount = coerce (2 :: Int) @@ -60,11 +60,10 @@ defaultTestConfig = Config , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever } - , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } + , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) + , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_roundtrip_exactprint_only = coerce False } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 7e73081..9bc144f 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -136,27 +136,19 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding - let - disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty - { _conf_debug = - mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } - } - ) + let disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let - disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty - { _conf_debug = - mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } - } - ) + let disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl @@ -458,7 +450,11 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do let config' = cZipWith fromOptionIdentity config $ mconcat (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) - toLocal config' filteredAnns $ ppDecl decl + toLocal config' filteredAnns + $ if (config' & _conf_roundtrip_exactprint_only & confUnpack) + then briDocMToPPM (briDocByExactNoComment decl) >>= layoutBriDoc + else ppDecl decl + let finalComments = filter (fst .> \case ExactPrint.AnnComment{} -> True diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 4c3d312..2891c3d 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -89,6 +89,7 @@ staticDefaultConfig = Config , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_roundtrip_exactprint_only = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions @@ -109,6 +110,7 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions ] } +-- brittany-next-binding --columns=200 cmdlineConfigParser :: CmdParser Identity out (CConfig Option) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! @@ -156,7 +158,7 @@ cmdlineConfigParser = do , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _dconf_roundtrip_exactprint_only = mempty } , _conf_layout = LayoutConfig { _lconfig_cols = optionConcat cols @@ -187,6 +189,7 @@ cmdlineConfigParser = do , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly } where falseToNothing = Option . Bool.bool Nothing (Just True) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 1da457e..91fdb4d 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -145,6 +145,11 @@ data CConfig f = Config , _conf_errorHandling :: CErrorHandlingConfig f , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f + , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + -- ^ this field is somewhat of a duplicate of the one in DebugConfig. + -- It is used for per-declaration disabling by the inline config + -- implementation. Could have re-used the existing field, but felt risky + -- to use a "debug" labeled field for non-debug functionality. } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 5f9f781..6f879b4 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -119,6 +119,7 @@ instance FromJSON (CConfig Maybe) where <*> v .:?= Text.pack "conf_errorHandling" <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" + <*> v .:? Text.pack "conf_roundtrip_exactprint_only" parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. -- 2.30.2 From 280b70f6bdb4674c3386abedad38af797af31ddf Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Apr 2018 18:08:07 +0200 Subject: [PATCH 162/478] Undo adding -j ghc-option in brittany.cabal --- brittany.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 0d172c8..5c76137 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -80,7 +80,6 @@ library { -Wall -fno-warn-unused-imports -fno-warn-redundant-constraints - -j } build-depends: { base >=4.9 && <4.12 -- 2.30.2 From 315a7e1ee1569726d4cc694a164a413b90d3b477 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 23 Apr 2018 19:33:04 +0200 Subject: [PATCH 163/478] Fix overflowing due to alignment; Add docs (alignment algorithm) --- src-literatetests/15-regressions.blt | 7 ++ .../Haskell/Brittany/Internal/Backend.hs | 105 +++++++++++++++--- 2 files changed, 99 insertions(+), 13 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index d59b844..3ba6bbf 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -599,3 +599,10 @@ func :: () => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + +#test alignment-potential-overflow +go l [] = Right l +go l ((IRType, _a) : eqr) = go l eqr +go l ((_, IRType) : eqr) = go l eqr +go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 +go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index a22d756..1285622 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -345,6 +345,81 @@ briDocIsMultiLine briDoc = rec briDoc BDNonBottomSpacing bd -> rec bd BDDebug _ bd -> rec bd +-- In theory +-- ========= + +-- .. this algorithm works roughly in these steps: +-- +-- 1. For each line, get the (nested) column info, descending as far as +-- BDCols nodes go. The column info is a (rose) tree where the leafs +-- are arbitrary (non-BDCols) BriDocs. +-- 2. Walk through the lines and compare its column info with that of its +-- predecessor. If both are non-leafs and the column "signatures" align +-- (they don't align e.g. when they are totally different syntactical +-- structures or the number of children differs), mark these parts of +-- the two tree structures as connected and recurse to its children +-- (i.e. again comparing the children in this line with the children in +-- the previous line). +-- 3. What we now have is one tree per line, and connections between "same" +-- nodes between lines. These connection can span multiple lines. +-- We next look at spacing information. This is available at the leafs, +-- but in this step we aggregate _over connections_. At the top level, this +-- gives us one piece of data: How long would each line be, if we fully +-- aligned everything (kept all connections "active"). In contrast to +-- just taking the sum of all leafs for each tree, this line length includes +-- the spaces used for alignment. +-- 4. Treat those lines where alignment would result in overflowing of the +-- column limit. This "treatment" is currently configurable, and can e.g. +-- mean: +-- a) we stop alignment alltogether, +-- b) we remove alignment just from the overflowing lines, +-- c) we reduce the number of spaces inserted in overflowing lines using +-- some technique to make them not overflow, but without reducing the +-- space insertion to zero, +-- d) don't do anything +-- 5. Actually print the lines, walking over each tree and inserting spaces +-- according to the info and decisions gathered in the previous steps. +-- +-- Possible improvements +-- ===================== +-- +-- - If alignment is disabled for specific lines, the aggregated per-connection +-- info of those lines is still retained and not recalculated. This can +-- result in spaces being inserted to create alignment with a line that +-- would overflow and thus gets disabled entirely. +-- An better approach would be to repeat step 3 after marking overflowing +-- lines as such, and not include the overflowing spacings as references +-- for non-overflowing ones. In the simplest case one additional iteration +-- would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine +-- this and first remove alignment in the deepest parts of the tree for +-- overflowing lines, repeating and moving upwards until no lines are +-- anymore overflowing. +-- Further, it may make sense to break up connections when overflowing would +-- occur. +-- - It may also make sense to not filter all overflowing lines, but remove +-- them one-by-one and in each step recalculate the aggregated connection +-- spacing info. Because removing one overflowing line from the calculation +-- may very well cause another previously overflowing line to not overflow +-- any longer. +-- There is also a nasty optimization problem hiding in there (find the +-- minimal amount of alignment disabling that results in no overflows) +-- but that is overkill. +-- +-- (with both these improvements there would be quite some repetition between +-- steps 3 and 4, but it should be possible to ensure termination. Still, +-- performance might become an issue as such an approach is not necessarily +-- linear in bridoc size any more.) +-- +-- In practice +-- =========== +-- +-- .. the current implementation is somewhat sloppy. Steps 1 and 2 +-- are executed in one step, step 3 already applies one strategy that disables +-- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some +-- of the calculations one might expect to occur in step 3. Steps 4 and 5 +-- are executed in the same recursion, too. +-- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue +-- mentioned in the first "possible improvement". alignColsLines :: LayoutConstraints m => [BriDoc] -> m () alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) @@ -362,7 +437,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock $ colInfos - <&> processInfo processedMap + <&> processInfo colMax processedMap where (colInfos, finalState) = StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) @@ -393,10 +468,9 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} - 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 + fmap colAggregation $ transpose $ Foldable.toList colss + (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols counter count l = if List.last posXs + List.last l <= colMax then count + 1 else count @@ -528,12 +602,13 @@ withAlloc lastFlag f = do $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } return info -processInfo :: LayoutConstraints m => ColMap2 -> ColInfo -> m () -processInfo m = \case +processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () +processInfo maxSpace m = \case ColInfoStart -> error "should not happen (TM)" ColInfoNo doc -> layoutBriDocM doc - ColInfo ind _ list -> do - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ + do + colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack curX <- do state <- mGet @@ -546,6 +621,7 @@ processInfo m = \case Nothing -> spaceAdd + i Just c -> c Right{} -> spaceAdd + let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols @@ -568,15 +644,18 @@ processInfo m = \case offsets = (subtract curX) <$> posXs fixed = offsets <&> fromIntegral .> (*factor) .> truncate _ -> posXs + let spacings = zipWith (-) + (List.tail fixedPosXs ++ [min maxX colMax]) + fixedPosXs -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs - let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do + let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do layoutWriteEnsureAbsoluteN destX - processInfo m (snd x) + processInfo s m (snd x) noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = - -- per-item check if there is overflowing. + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. then noAlignAct else alignAct case alignMode of -- 2.30.2 From 696f72d3362e63a137bca2a47c5699bb2fe8eed5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 23 Apr 2018 23:43:51 +0200 Subject: [PATCH 164/478] Fixup last two commits (tests were effectively disabled - re-enable tests - un-break tests by fixing the alignment code behaviour --- src-literatetests/Main.hs | 2 +- src/Language/Haskell/Brittany/Internal/Backend.hs | 15 ++++++++++++--- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 42e4c19..785d192 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -183,7 +183,7 @@ defaultTestConfig = Config } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_forward = ForwardOptions {_options_ghc = Identity []} - , _conf_roundtrip_exactprint_only = coerce True + , _conf_roundtrip_exactprint_only = coerce False } contextFreeTestConfig :: Config diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 1285622..6b38480 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -56,7 +56,7 @@ data ColInfo instance Show ColInfo where show ColInfoStart = "ColInfoStart" - show ColInfoNo{} = "ColInfoNo{}" + show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list data ColBuildState = ColBuildState @@ -433,7 +433,8 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack case () of - _ -> + _ -> do + -- tellDebugMess ("processedMap: " ++ show processedMap) sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock $ colInfos @@ -623,7 +624,12 @@ processInfo maxSpace m = \case Right{} -> spaceAdd let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX - let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m + let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m + let maxCols2 = list <&> \e -> case e of + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l + let maxCols = zipWith max maxCols1 maxCols2 let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols -- handle the cases that the vertical alignment leads to more than max -- cols: @@ -647,8 +653,11 @@ processInfo maxSpace m = \case let spacings = zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs + -- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs + -- tellDebugMess $ "list = " ++ show list + -- tellDebugMess $ "maxSpace = " ++ show maxSpace let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do layoutWriteEnsureAbsoluteN destX processInfo s m (snd x) -- 2.30.2 From a237e591b28b521dedeb0a6fe2ace1fd7ab60501 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 24 Apr 2018 00:47:50 +0200 Subject: [PATCH 165/478] Implement `--obfuscate` Support replacing all (non-keyword) identifiers with randomly generated characters --- brittany.cabal | 2 + src-brittany/Main.hs | 6 +- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/Config.hs | 3 + .../Haskell/Brittany/Internal/Config/Types.hs | 1 + .../Internal/Config/Types/Instances.hs | 1 + .../Haskell/Brittany/Internal/Obfuscation.hs | 100 ++++++++++++++++++ 8 files changed, 114 insertions(+), 1 deletion(-) create mode 100644 src/Language/Haskell/Brittany/Internal/Obfuscation.hs diff --git a/brittany.cabal b/brittany.cabal index 5c76137..38522cf 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -55,6 +55,7 @@ library { Language.Haskell.Brittany.Internal.Config Language.Haskell.Brittany.Internal.Config.Types Language.Haskell.Brittany.Internal.Config.Types.Instances + Language.Haskell.Brittany.Internal.Obfuscation Paths_brittany } other-modules: { @@ -112,6 +113,7 @@ library { , czipwith >=1.0.1.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.5 , filepath >=1.4.1.0 && <1.5 + , random >= 1.1 && <1.2 } default-extensions: { CPP diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 3b6f0b2..ba66188 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -28,6 +28,7 @@ import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Config import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Obfuscation import qualified Text.PrettyPrint as PP @@ -272,7 +273,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx let out = TextL.toStrict $ if hackAroundIncludes then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw else outRaw - pure $ (ews, out) + out' <- if config & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out') let customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = 0 :: Int customErrOrder ErrorOutputCheck{} = 1 diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 785d192..e505ffa 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -184,6 +184,7 @@ defaultTestConfig = Config , _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index c14b3b8..3394dc9 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -66,4 +66,5 @@ defaultTestConfig = Config , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False + , _conf_obfuscate = coerce False } diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 2891c3d..e8ff5d6 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -90,6 +90,7 @@ staticDefaultConfig = Config { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions @@ -143,6 +144,7 @@ cmdlineConfigParser = do ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config { _conf_version = mempty @@ -190,6 +192,7 @@ cmdlineConfigParser = do { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Option . Bool.bool Nothing (Just True) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 91fdb4d..e157c77 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -146,6 +146,7 @@ data CConfig f = Config , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _conf_obfuscate :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config -- implementation. Could have re-used the existing field, but felt risky diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 6f879b4..82edaed 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -120,6 +120,7 @@ instance FromJSON (CConfig Maybe) where <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" <*> v .:? Text.pack "conf_roundtrip_exactprint_only" + <*> v .:? Text.pack "conf_obfuscate" parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs new file mode 100644 index 0000000..5bdcfa8 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -0,0 +1,100 @@ +module Language.Haskell.Brittany.Internal.Obfuscation + ( obfuscate + ) +where + + + +#include "prelude.inc" + +import Data.Char +import System.Random + + + +obfuscate :: Text -> IO Text +obfuscate input = do + let predi x = isAlphaNum x || x `elem` "_'" + let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) + let idents = Set.toList $ Set.fromList $ filter (all predi) groups + let exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x + let filtered = filter exceptionFilter idents + mappings <- fmap Map.fromList $ filtered `forM` \x -> do + r <- createAlias x + pure (x, r) + let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings) + pure $ Text.concat $ fmap Text.pack groups' + +keywords :: [String] +keywords = + [ "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "mdo" + , "else" + , "forall" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "qualified" + , "then" + , "type" + , "where" + , "_" + , "foreign" + , "ccall" + , "as" + , "safe" + , "unsafe" + , "hiding" + , "proc" + , "rec" + , "family" + ] + +extraKWs :: [String] +extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] + +createAlias :: String -> IO String +createAlias xs = go NoHint xs + where + go _hint "" = pure "" + go hint (c : cr) = do + c' <- case hint of + VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] + VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c + cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr + pure (c' : cr') + +data Hint = NoHint | VocalHint | NoVocalHint + +_randomRange :: Random a => a -> a -> IO a +_randomRange lo hi = do + gen <- getStdGen + let (x, gen') = randomR (lo, hi) gen + setStdGen gen' + pure x + +randomFrom :: Random a => [a] -> IO a +randomFrom l = do + let hi = length l - 1 + gen <- getStdGen + let (x, gen') = randomR (0, hi) gen + setStdGen gen' + pure $ l List.!! x -- 2.30.2 From e9aacb27ffcd1bdf350d59a56178688284cd4f8f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 25 Apr 2018 19:54:35 +0200 Subject: [PATCH 166/478] Implement hacky workaround for issue 89 --- src-literatetests/15-regressions.blt | 5 +++++ src/Language/Haskell/Brittany/Internal.hs | 14 ++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 3ba6bbf..88f6e6f 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -606,3 +606,8 @@ go l ((IRType, _a) : eqr) = go l eqr go l ((_, IRType) : eqr) = go l eqr go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 + +#test issue 89 - type-family-instance + +type instance (XPure StageParse) = () +type Pair a = (a, a) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 9bc144f..b4c59b9 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -514,6 +514,20 @@ ppDecl d@(L loc decl) = case decl of Left ns -> docLines $ return <$> ns Right n -> return n layoutBriDoc briDoc + InstD (TyFamInstD{}) -> do + -- this is a (temporary (..)) workaround for "type instance" decls + -- that do not round-trip through exactprint properly. + let fixer s = case List.stripPrefix "type " s of + Just rest | not ("instance" `isPrefixOf` rest) -> + "type instance " ++ rest + _ -> s + str <- mAsk <&> \anns -> + intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns + bd <- briDocMToPPM $ allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) + (foldedAnnKeys d) + False + (Text.pack str) + layoutBriDoc bd _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc -- Prints the information associated with the module annotation -- 2.30.2 From 929e465fd42a4b87f86d1f36656b419eaa72b1a4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 25 Apr 2018 20:15:47 +0200 Subject: [PATCH 167/478] Refactor a bit (Internal.ppDecl -> Decl.layoutDecl) --- src/Language/Haskell/Brittany/Internal.hs | 55 ++----------------- .../Brittany/Internal/ExactPrintUtils.hs | 22 ++++++++ .../Brittany/Internal/Layouters/Decl.hs | 30 +++++++++- 3 files changed, 57 insertions(+), 50 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index b4c59b9..6bc70eb 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -450,10 +450,12 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do let config' = cZipWith fromOptionIdentity config $ mconcat (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) - toLocal config' filteredAnns - $ if (config' & _conf_roundtrip_exactprint_only & confUnpack) - then briDocMToPPM (briDocByExactNoComment decl) >>= layoutBriDoc - else ppDecl decl + let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + toLocal config' filteredAnns $ do + bd <- briDocMToPPM $ if exactprintOnly + then briDocByExactNoComment decl + else layoutDecl decl + layoutBriDoc bd let finalComments = filter (fst .> \case @@ -477,19 +479,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () -withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () -withTransformedAnns ast m = do - -- TODO: implement `local` for MultiReader/MultiRWS - readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - m - MultiRWSS.mPutRawR readers - where - f anns = - let ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced - getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of @@ -498,38 +487,6 @@ getDeclBindingNames (L _ decl) = case decl of _ -> [] -ppDecl :: LHsDecl GhcPs -> 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 briDoc - ValD bind -> -- trace (_bindHead bind) $ - withTransformedAnns d $ do - -- Old.layoutBind (L loc bind) - briDoc <- briDocMToPPM $ do - eitherNode <- layoutBind (L loc bind) - case eitherNode of - Left ns -> docLines $ return <$> ns - Right n -> return n - layoutBriDoc briDoc - InstD (TyFamInstD{}) -> do - -- this is a (temporary (..)) workaround for "type instance" decls - -- that do not round-trip through exactprint properly. - let fixer s = case List.stripPrefix "type " s of - Just rest | not ("instance" `isPrefixOf` rest) -> - "type instance " ++ rest - _ -> s - str <- mAsk <&> \anns -> - intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns - bd <- briDocMToPPM $ allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) - (foldedAnnKeys d) - False - (Text.pack str) - layoutBriDoc bd - _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc - -- Prints the information associated with the module annotation -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule GhcPs) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 19bc835..375c779 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -7,6 +7,7 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils , commentAnnFixTransformGlob , extractToplevelAnns , foldedAnnKeys + , withTransformedAnns ) where @@ -17,6 +18,8 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Utils +import Data.Data +import Data.HList.HList import DynFlags ( getDynFlags ) import GHC ( runGhc, GenLocated(L), moduleNameString ) @@ -266,6 +269,25 @@ foldedAnnKeys ast = SYB.everything where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) +withTransformedAnns + :: Data ast + => ast + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a +withTransformedAnns ast m = do + -- TODO: implement `local` for MultiReader/MultiRWS + readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR + MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) + x <- m + MultiRWSS.mPutRawR readers + pure x + where + f anns = + let ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced + + #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 53f58b7..d4e8bce 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -2,7 +2,8 @@ {-# LANGUAGE TypeApplications #-} module Language.Haskell.Brittany.Internal.Layouters.Decl - ( layoutSig + ( layoutDecl + , layoutSig , layoutBind , layoutLocalBinds , layoutGuardLStmt @@ -20,6 +21,11 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.Utils + import GHC ( runGhc, GenLocated(L), moduleNameString ) import SrcLoc ( SrcSpan ) import HsSyn @@ -40,6 +46,28 @@ import Bag ( mapBagM ) +layoutDecl :: ToBriDoc HsDecl +layoutDecl d@(L loc decl) = case decl of + SigD sig -> withTransformedAnns d $ layoutSig (L loc sig) + ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case + Left ns -> docLines $ return <$> ns + Right n -> return n + InstD (TyFamInstD{}) -> do + -- this is a (temporary (..)) workaround for "type instance" decls + -- that do not round-trip through exactprint properly. + let fixer s = case List.stripPrefix "type " s of + Just rest | not ("instance" `isPrefixOf` rest) -> + "type instance " ++ rest + _ -> s + str <- mAsk <&> \anns -> + intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns + allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) + (foldedAnnKeys d) + False + (Text.pack str) + _ -> briDocByExactNoComment d + + layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ -- 2.30.2 From 031df539b35c2cf67b1642fb1b6ad4739feb9e0a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 17:09:31 +0200 Subject: [PATCH 168/478] Prepare release (bump to 0.11.0.0, changelog) --- ChangeLog.md | 42 ++++++++++++++++++++++++++++++++++++++++++ brittany.cabal | 2 +- 2 files changed, 43 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 253226b..9d6a73b 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,47 @@ # Revision history for brittany +## 0.11.0.0 -- May 2018 + +* Support for ghc-8.4 +* Implement inline-config + e.g. "-- brittany --indent=4" + + respects the following comment forms as input: + + ~~~~ + source comment affected target + ====================================================== + "-- brittany CONFIG" whole module + "-- brittany-next-binding CONFIG" next binding + "-- brittany-disable-next-binding" next binding + "-- brittany @ myExampleFunc CONFIG" `myExampleFunc` + ~~~~ + + multiline-comments are supported too, although + the specification must still be a single line. E.g. + + > "{- brittany --columns 50 -}" + + CONFIG is either: + + 1) one or more flags in the form of what brittany accepts + on the commandline, e.g. "-- columns 50", or + 2) one or more specifications in the form of what brittany + accepts in its config files for the layouting config + (a one-line yaml document), e.g. "{ lconfig_cols: 50 }" +* Implement `--obfuscate` that replaces non-keyword identifiers with random + names +* Do not write files unless there are changes (don't update modtime) + (`--write-mode=inplace`) (#93) +* Bugfixes: + - Fix empty function constraints (`() => IO ()`) (#133) + - Fix overflowing columns caused by aligning with surrounding lines + for certain complex cases +* Layouting changes: + - On default settings, allow single-line module header + `module MyModule where` when no exports + - Fix one case of non-optimal layouting for if-then-else + ## 0.10.0.0 -- March 2018 * Implement module/exports/imports layouting (thanks to sniperrifle2004) diff --git a/brittany.cabal b/brittany.cabal index 38522cf..b1896ed 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.10.0.0 +version: 0.11.0.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 03fd81f8512c458bd040910f0cf42281eede20df Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 17:13:32 +0200 Subject: [PATCH 169/478] Update Readme and copyright dates [ci skip] --- README.md | 6 +++--- brittany.cabal | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index a3a106c..235810a 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.0.*` and `8.2.*`. +- Supports GHC versions `8.0`, `8.2` and `8.4`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. @@ -72,7 +72,7 @@ log the size of the input, but _not_ the full input/output of requests.) ~~~~.sh cabal unpack brittany - cd brittany-0.8.0.2 + cd brittany-0.11.0.0 # 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. @@ -159,7 +159,7 @@ a good amount of high-level documentation at # License -Copyright (C) 2016-2017 Lennart Spitzner +Copyright (C) 2016-2018 Lennart Spitzner This program is free software: you can redistribute it and/or modify it under the terms of the diff --git a/brittany.cabal b/brittany.cabal index b1896ed..f6cc16e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -12,7 +12,7 @@ license: AGPL-3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner -copyright: Copyright (C) 2016-2017 Lennart Spitzner +copyright: Copyright (C) 2016-2018 Lennart Spitzner category: Language build-type: Simple cabal-version: 1.18 -- 2.30.2 From d40b8409803d8b2ec9d7b6f9daddf55c082bd950 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 17:19:31 +0200 Subject: [PATCH 170/478] Amend changelog (issue 89 fix) [ci skip] --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index 9d6a73b..2225ddc 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -37,6 +37,7 @@ - Fix empty function constraints (`() => IO ()`) (#133) - Fix overflowing columns caused by aligning with surrounding lines for certain complex cases + - Implement hacky workaround for `type instance`s (`-XTypeFamilies`) (#89) * Layouting changes: - On default settings, allow single-line module header `module MyModule where` when no exports -- 2.30.2 From 601dd05be684571f4411bcae94316a50e4e76602 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 16:55:20 +0200 Subject: [PATCH 171/478] Change test file name --- .../{tests-context-free.blt => 30-tests-context-free.blt} | 0 src-literatetests/Main.hs | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename src-literatetests/{tests-context-free.blt => 30-tests-context-free.blt} (100%) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/30-tests-context-free.blt similarity index 100% rename from src-literatetests/tests-context-free.blt rename to src-literatetests/30-tests-context-free.blt diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index e505ffa..8f492d1 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -46,7 +46,7 @@ main = do $ filter (".blt"`isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) let groups = createChunks =<< inputs - inputCtxFree <- Text.IO.readFile "src-literatetests/tests-context-free.blt" + inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree hspec $ do groups `forM_` \(groupname, tests) -> do -- 2.30.2 From 004dee73e0802211e6f75c82b147aed0105d3e76 Mon Sep 17 00:00:00 2001 From: Bryan Richter Date: Sun, 22 Apr 2018 15:54:19 -0400 Subject: [PATCH 172/478] Add test for IndentPolicyMultiple --- .../40-indent-policy-multiple.blt | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 src-literatetests/40-indent-policy-multiple.blt diff --git a/src-literatetests/40-indent-policy-multiple.blt b/src-literatetests/40-indent-policy-multiple.blt new file mode 100644 index 0000000..42b19ca --- /dev/null +++ b/src-literatetests/40-indent-policy-multiple.blt @@ -0,0 +1,33 @@ +############################################################################### +############################################################################### +############################################################################### +#group indent-policy-multiple +############################################################################### +############################################################################### +############################################################################### + +#test long +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }} +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + +#test let +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }} +foo = do + let + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo + +#test nested do-block +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }} +foo = asdyf8asdf + "ajsdfas" + [ asjdf asyhf $ do + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ] -- 2.30.2 From 9ab17cc899718714fb387a475afde5a11041ea69 Mon Sep 17 00:00:00 2001 From: Bryan Richter Date: Sun, 22 Apr 2018 15:24:40 +0200 Subject: [PATCH 173/478] Implement IndentPolicyMultiple --- .../Brittany/Internal/Layouters/Decl.hs | 2 +- .../Brittany/Internal/Layouters/Expr.hs | 42 +++++++++++-------- .../Brittany/Internal/Layouters/Import.hs | 2 +- .../Brittany/Internal/Layouters/Stmt.hs | 30 +++++++------ .../Brittany/Internal/Transformations/Alt.hs | 10 ++++- 5 files changed, 49 insertions(+), 37 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index d4e8bce..19a6f48 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -436,7 +436,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha -- multiple clauses added in-paragraph, each in a single line -- example: foo | bar = baz -- | lll = asd - addAlternativeCond (indentPolicy /= IndentPolicyLeft) + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docLines $ [ docSeq [ appSep $ docForceSingleline $ return patDoc diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 93a06ac..a9deffc 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -422,7 +422,8 @@ layoutExpr lexpr@(L _ expr) = do let maySpecialIndent = case indentPolicy of IndentPolicyLeft -> BrIndentRegular - _ -> BrIndentSpecial 3 + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. runFilteredAlternative $ do @@ -541,7 +542,10 @@ layoutExpr lexpr@(L _ expr) = do let ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = - if indentPolicy == IndentPolicyLeft then x else y + case indentPolicy of + IndentPolicyLeft -> x + IndentPolicyMultiple -> x + IndentPolicyFree -> y -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), -- but is here due to ghc-exactprint's DP handling of "let" in @@ -596,18 +600,21 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo + let noHangingBinds = + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular expDoc1 + ] + ] addAlternativeCond (indentPolicy == IndentPolicyLeft) - $ docLines - [ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular expDoc1 - ] - ] - addAlternativeCond (indentPolicy /= IndentPolicyLeft) + $ docLines noHangingBinds + addAlternativeCond (indentPolicy == IndentPolicyMultiple) + $ docLines noHangingBinds + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docLines [ docSeq [ appSep $ docLit $ Text.pack "let" @@ -877,7 +884,7 @@ layoutExpr lexpr@(L _ expr) = do -- container { fieldA = blub -- , fieldB = blub -- } - addAlternativeCond (indentPolicy /= IndentPolicyLeft) + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc , docSetBaseY $ docLines $ let @@ -918,9 +925,10 @@ layoutExpr lexpr@(L _ expr) = do $ docPar (docNodeAnnKW lexpr Nothing rExprDoc) (docNonBottomSpacing $ docLines $ let - expressionWrapper = if indentPolicy == IndentPolicyLeft - then docForceParSpacing - else docSetBaseY + expressionWrapper = case indentPolicy of + IndentPolicyLeft -> docForceParSpacing + IndentPolicyMultiple -> docForceParSpacing + IndentPolicyFree -> docSetBaseY line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit rF1n diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 3f56dcd..aa4380f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -48,7 +48,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let - compact = indentPolicy == IndentPolicyLeft + compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg masT = Text.pack . moduleNameString . prepModName <$> mas diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 70daf6c..33b700e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -58,11 +58,11 @@ layoutStmt lstmt@(L _ stmt) = do docCols ColDoLet [ appSep $ docLit $ Text.pack "let" - , ( if indentPolicy == IndentPolicyLeft - then docForceSingleline - else docSetBaseAndIndent - ) - $ return bindDoc + , let f = case indentPolicy of + IndentPolicyFree -> docSetBaseAndIndent + IndentPolicyLeft -> docForceSingleline + IndentPolicyMultiple -> docForceSingleline + in f $ return bindDoc ] , -- let -- bind = expr @@ -74,8 +74,8 @@ layoutStmt lstmt@(L _ stmt) = do -- let aaa = expra -- bbb = exprb -- ccc = exprc - addAlternativeCond (indentPolicy /= IndentPolicyLeft) - $ docSeq + -- TODO: Allow this for IndentPolicyMultiple when indentAmount = 4 + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines $ return <$> bindDocs ] @@ -83,16 +83,14 @@ layoutStmt lstmt@(L _ stmt) = do -- aaa = expra -- bbb = exprb -- ccc = exprc - addAlternative $ - docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 -- stmt3 - addAlternativeCond (indentPolicy /= IndentPolicyLeft) - $ docSeq + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq [ docLit (Text.pack "rec") , docSeparator , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts @@ -101,9 +99,9 @@ layoutStmt lstmt@(L _ stmt) = do -- stmt1 -- stmt2 -- stmt3 - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docLit (Text.pack "rec")) + (docLines $ layoutStmt <$> stmts) BodyStmt expr _ _ _ -> do expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index f7ed523..5b833fd 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -142,17 +142,23 @@ transformAlts = BDFAddBaseY indent bd -> do acp <- mGet indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let indAdd = case indent of BrIndentNone -> 0 BrIndentRegular -> indAmount BrIndentSpecial i -> i - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + let indAdd' = + if indPolicy == IndentPolicyMultiple + then + max 0 (indAdd - ((_acp_indent acp + indAdd) `mod` indAmount)) + else indAdd + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd' } r <- rec bd acp' <- mGet mSet $ acp' { _acp_indent = _acp_indent acp } return $ case indent of BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd') r BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r BDFBaseYPushCur bd -> do acp <- mGet -- 2.30.2 From e91bb6aec979d26ceca93c7827cbceff444fa582 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 23:19:44 +0200 Subject: [PATCH 174/478] Clean up IndentPolicyMultiple --- .../40-indent-policy-multiple.blt | 3 -- .../Brittany/Internal/Layouters/Expr.hs | 42 +++++++++---------- 2 files changed, 20 insertions(+), 25 deletions(-) diff --git a/src-literatetests/40-indent-policy-multiple.blt b/src-literatetests/40-indent-policy-multiple.blt index 42b19ca..80288bd 100644 --- a/src-literatetests/40-indent-policy-multiple.blt +++ b/src-literatetests/40-indent-policy-multiple.blt @@ -8,14 +8,12 @@ #test long -- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }} func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj #test let -- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }} foo = do let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = @@ -24,7 +22,6 @@ foo = do #test nested do-block -- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }} foo = asdyf8asdf "ajsdfas" [ asjdf asyhf $ do diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a9deffc..6e32798 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -540,12 +540,12 @@ layoutExpr lexpr@(L _ expr) = do mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) =<< layoutLocalBinds binds let - ifIndentLeftElse :: a -> a -> a - ifIndentLeftElse x y = + ifIndentFreeElse :: a -> a -> a + ifIndentFreeElse x y = case indentPolicy of - IndentPolicyLeft -> x - IndentPolicyMultiple -> x - IndentPolicyFree -> y + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), -- but is here due to ghc-exactprint's DP handling of "let" in @@ -566,7 +566,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" - , ifIndentLeftElse docForceSingleline docSetBaseAndIndent + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline $ bindDoc ] , docAddBaseY BrIndentRegular @@ -576,8 +576,8 @@ layoutExpr lexpr@(L _ expr) = do ] , docAlt [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentLeftElse "in" "in " - , ifIndentLeftElse docForceSingleline docSetBaseAndIndent expDoc1 + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 ] , docAddBaseY BrIndentRegular $ docPar @@ -610,21 +610,19 @@ layoutExpr lexpr@(L _ expr) = do , docAddBaseY BrIndentRegular expDoc1 ] ] - addAlternativeCond (indentPolicy == IndentPolicyLeft) - $ docLines noHangingBinds - addAlternativeCond (indentPolicy == IndentPolicyMultiple) - $ docLines noHangingBinds - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines bindDocs + addAlternative $ case indentPolicy of + IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyMultiple -> docLines noHangingBinds + IndentPolicyFree -> docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines bindDocs + ] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY expDoc1 + ] ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY expDoc1 - ] - ] addAlternative $ docLines [ docAddBaseY BrIndentRegular -- 2.30.2 From dd53948a23a2809630a754bf09c91de2ad051669 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 23:20:11 +0200 Subject: [PATCH 175/478] Fix IndentPolicyMultiple for indentAmount>4 --- .../40-indent-policy-multiple.blt | 18 ++++++-- .../Brittany/Internal/Transformations/Alt.hs | 44 +++++++++++-------- 2 files changed, 41 insertions(+), 21 deletions(-) diff --git a/src-literatetests/40-indent-policy-multiple.blt b/src-literatetests/40-indent-policy-multiple.blt index 80288bd..b75c726 100644 --- a/src-literatetests/40-indent-policy-multiple.blt +++ b/src-literatetests/40-indent-policy-multiple.blt @@ -12,14 +12,26 @@ func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj -#test let +#test let indAmount=4 -- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } foo = do - let - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa foo +#test let indAmount=8 +-- brittany { lconfig_indentAmount: 8, lconfig_indentPolicy: IndentPolicyMultiple } +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo + #test nested do-block -- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } foo = asdyf8asdf diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 5b833fd..7361ce6 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -141,24 +141,14 @@ transformAlts = BDFSeparator -> processSpacingSimple bdX $> bdX BDFAddBaseY indent bd -> do acp <- mGet - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - let indAdd' = - if indPolicy == IndentPolicyMultiple - then - max 0 (indAdd - ((_acp_indent acp + indAdd) `mod` indAmount)) - else indAdd - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd' } + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } r <- rec bd acp' <- mGet mSet $ acp' { _acp_indent = _acp_indent acp } return $ case indent of BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd') r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r BDFBaseYPushCur bd -> do acp <- mGet @@ -321,11 +311,7 @@ transformAlts = return $ reWrap $ BDFLines (l':lr') BDFEnsureIndent indent bd -> do acp <- mGet - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i + indAdd <- fixIndentationForMultiple acp indent mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid, in general. @@ -863,3 +849,25 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i VerticalSpacingParNone -> VerticalSpacingParSome $ x1 VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + +fixIndentationForMultiple + :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int +fixIndentationForMultiple acp indent = do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + -- for IndentPolicyMultiple, we restrict the amount of added + -- indentation in such a manner that we end up on a multiple of the + -- base indentation. + indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + pure $ if indPolicy == IndentPolicyMultiple + then + let indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 + else indAddRaw -- 2.30.2 From 4973298f309f8d88f431f789b3bb421acc936bc6 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 23:21:31 +0200 Subject: [PATCH 176/478] Support same-line let decl when indentAmount>=4 --- .../Brittany/Internal/Layouters/Stmt.hs | 89 +++++++++++-------- 1 file changed, 50 insertions(+), 39 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 33b700e..7a9b922 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -13,7 +13,10 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import GHC ( runGhc, GenLocated(L), moduleNameString ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + ) import HsSyn import Name import qualified FastString @@ -28,6 +31,8 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt lstmt@(L _ stmt) = do indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentAmount :: Int <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack docWrapNode lstmt $ case stmt of LastStmt body False _ -> do layoutExpr body @@ -47,45 +52,51 @@ layoutStmt lstmt@(L _ stmt) = do $ docPar (docLit $ Text.pack "<-") (expDoc) ] ] - LetStmt binds -> layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" -- i just tested - -- it, and it is - -- indeed allowed. - -- heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAlt - [ -- let bind = expr - docCols - ColDoLet - [ appSep $ docLit $ Text.pack "let" - , let f = case indentPolicy of - IndentPolicyFree -> docSetBaseAndIndent - IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple -> docForceSingleline - in f $ return bindDoc + LetStmt binds -> do + let isFree = indentPolicy == IndentPolicyFree + let indentFourPlus = indentAmount >= 4 + layoutLocalBinds binds >>= \case + Nothing -> docLit $ Text.pack "let" + -- i just tested the above, and it is indeed allowed. heh. + Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [bindDoc] -> docAlt + [ -- let bind = expr + docCols + ColDoLet + [ appSep $ docLit $ Text.pack "let" + , let + f = case indentPolicy of + IndentPolicyFree -> docSetBaseAndIndent + IndentPolicyLeft -> docForceSingleline + IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc + ] + , -- let + -- bind = expr + docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) ] - , -- let - -- bind = expr - docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - ] - Just bindDocs -> runFilteredAlternative $ do - -- let aaa = expra - -- bbb = exprb - -- ccc = exprc - -- TODO: Allow this for IndentPolicyMultiple when indentAmount = 4 - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs - ] - -- let - -- aaa = expra - -- bbb = exprb - -- ccc = exprc - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + Just bindDocs -> runFilteredAlternative $ do + -- let aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (isFree || indentFourPlus) $ docSeq + [ appSep $ docLit $ Text.pack "let" + , let f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs + ] + -- let + -- aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (not indentFourPlus) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 -- 2.30.2 From 8bda9827b8b1353638c95cb3bd9e36ea2feb1eaa Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 1 May 2018 23:30:56 +0200 Subject: [PATCH 177/478] Amend changelog [ci skip] --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 2225ddc..5dcb20c 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -29,6 +29,8 @@ 2) one or more specifications in the form of what brittany accepts in its config files for the layouting config (a one-line yaml document), e.g. "{ lconfig_cols: 50 }" +* Implement `IndentPolicyMultiple` (thanks to Bryan Richter @chreekat) + Restrict indentation amounts to `n * indentAmount` * Implement `--obfuscate` that replaces non-keyword identifiers with random names * Do not write files unless there are changes (don't update modtime) @@ -42,6 +44,8 @@ - On default settings, allow single-line module header `module MyModule where` when no exports - Fix one case of non-optimal layouting for if-then-else + - Allow same-line let binding inside do-notation with + `IndentPolicyLeft/Multiple` and `indentAmount>=4` ## 0.10.0.0 -- March 2018 -- 2.30.2 From 82b59299cb912efec66af8eff75a0b11a2d18fc0 Mon Sep 17 00:00:00 2001 From: Leon Schoorl Date: Mon, 7 May 2018 11:56:19 +0200 Subject: [PATCH 178/478] Fix link to README.md --- doc/implementation/theory.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/implementation/theory.md b/doc/implementation/theory.md index f01b1ba..50f07ff 100644 --- a/doc/implementation/theory.md +++ b/doc/implementation/theory.md @@ -1,6 +1,6 @@ # Introduction -[The readme](../../master/README.md) mentions a couple of goals for this +[The readme](../../README.md) mentions a couple of goals for this project, including the following two: - Be clever about using the available horizontal space while not overflowing -- 2.30.2 From f5b5fe9f7499960e990d360b535f0a63fb103257 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 10 May 2018 17:52:15 +0200 Subject: [PATCH 179/478] Bump aeson upper bound --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index f6cc16e..bc6764a 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -100,7 +100,7 @@ library { , directory >=1.2.6.2 && <1.4 , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.9 - , aeson >=1.0.1.0 && <1.3 + , aeson >=1.0.1.0 && <1.4 , extra >=1.4.10 && <1.7 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 -- 2.30.2 From f75127b3a5cb595bbb0d3c8d97474be05dd1c522 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 16 May 2018 21:19:36 +0200 Subject: [PATCH 180/478] Make non-bottom-spacing affect sameline, too (fixes #144) --- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 4 ++-- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 5 +++-- .../Haskell/Brittany/Internal/Transformations/Alt.hs | 5 +++-- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 19a6f48..ee0596f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -421,8 +421,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha addAlternative $ docLines $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular - $ docNonBottomSpacing + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular $ docAddBaseY BrIndentRegular $ return body ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 6e32798..80f9d6a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -601,13 +601,14 @@ layoutExpr lexpr@(L _ expr) = do -- in -- fooooooooooooooooooo let noHangingBinds = - [ docAddBaseY BrIndentRegular + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines bindDocs) , docSeq [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular expDoc1 + , docAddBaseY BrIndentRegular + $ docForceParSpacing expDoc1 ] ] addAlternative $ case indentPolicy of diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 7361ce6..053e032 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -707,7 +707,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc -- paragraph". That most importantly means that Lines should never -- be inserted anywhere but at the start of the line. A -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- fmap filterAndLimit <$> rec `mapM` ls + lSpss <- map filterAndLimit <$> rec `mapM` ls let worbled = fmap reverse $ sequence $ reverse @@ -745,7 +745,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc return $ if null mVs then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] else mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParAlways i -> VerticalSpacingParAlways i VerticalSpacingParSome i -> VerticalSpacingParAlways i -- 2.30.2 From ef7b0fcc702b59c556d46a3652eacf559ecf089d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 16 May 2018 21:25:40 +0200 Subject: [PATCH 181/478] Add test for #144 --- src-literatetests/15-regressions.blt | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 88f6e6f..2d769d9 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -608,6 +608,25 @@ go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 #test issue 89 - type-family-instance - type instance (XPure StageParse) = () type Pair a = (a, a) + +#test issue 144 +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = + let + eyuAfrarIso' + :: (RveoexdxunuAafalm -> Axlau (Axlau (a, OinejrdCplle))) + -> Gbodoy + -> Axlau (Axlau OinejrdCplle, Gbodoy) + eyuAfrarIso' = ulcPaaekBst cnehokzozwbVaguvu + amkgoxEhalazJjxunecCuIfaw + :: Axlau (Axlau OinejrdCplle, Gbodoy) -> Axlau RqlnrluYqednbCiggxi + amkgoxEhalazJjxunecCuIfaw uKqviuBisjtn = do + (sEmo, quc) <- uKqviuBisjtn + pure (xoheccewfWoeyiagOkfodiq sEmo quc) + xoheccewfWoeyiagOkfodiq + :: Axlau OinejrdCplle -> Gbodoy -> RqlnrluYqednbCiggxi + xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of + Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo + in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) -- 2.30.2 From bdee27cb5989931dc4a634c240c407b10d85a865 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 25 May 2018 17:57:36 +0200 Subject: [PATCH 182/478] Add spaces around record braces (single-line) (fixes #126) --- src-literatetests/15-regressions.blt | 8 ++++---- src-literatetests/30-tests-context-free.blt | 2 +- .../Brittany/Internal/Layouters/Expr.hs | 20 ++++++++++--------- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 2d769d9..e066ca4 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -43,7 +43,7 @@ func = do } #test record construction 1 -func = Foo {_lstate_indent = _lstate_indent state} +func = Foo { _lstate_indent = _lstate_indent state } #test record construction 2 func = Foo @@ -478,17 +478,17 @@ foo = #test issue 52 a {-# LANGUAGE RecordWildCards #-} -v = A {a = 1, ..} where b = 2 +v = A { a = 1, .. } where b = 2 #test issue 52 b {-# LANGUAGE RecordWildCards #-} -v = A {..} where b = 2 +v = A { .. } where b = 2 #test issue 52 c {-# LANGUAGE RecordWildCards #-} -v = A {a = 1, b = 2, c = 3} +v = A { a = 1, b = 2, c = 3 } #test issue 63 a #pending fix does not work on 8.0.2 diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 2d1c421..3ecae6f 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -931,7 +931,7 @@ func = do } #test record construction 1 -func = Foo {_lstate_indent = _lstate_indent state} +func = Foo { _lstate_indent = _lstate_indent state } #test record construction 2 func = Foo diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 80f9d6a..4ee0920 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -749,8 +749,8 @@ layoutExpr lexpr@(L _ expr) = do then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 appender wrapper = - [ appender $ docLit $ Text.pack "{" + let line1 wrapper = + [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior fd1l $ appSep $ docLit fd1n , case fd1e of Just x -> docSeq @@ -776,8 +776,9 @@ layoutExpr lexpr@(L _ expr) = do docAlt [ docSeq $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] - ++ line1 id docForceSingleline + ++ line1 docForceSingleline ++ join (lineR docForceSingleline) + ++ [docSeparator] ++ lineN , docSetParSpacing $ docAddBaseY BrIndentRegular @@ -785,14 +786,14 @@ layoutExpr lexpr@(L _ expr) = do (docNodeAnnKW lexpr Nothing nameDoc) ( docNonBottomSpacing $ docLines - $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] + $ [docCols ColRecUpdate $ line1 (docAddBaseY BrIndentRegular)] ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) ++ [docSeq lineN] ) ] RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " {..}" + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do @@ -800,8 +801,8 @@ layoutExpr lexpr@(L _ expr) = do then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 appender wrapper = - [ appender $ docLit $ Text.pack "{" + let line1 wrapper = + [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior fd1l $ appSep $ docLit fd1n , case fd1e of Just x -> docSeq @@ -831,9 +832,10 @@ layoutExpr lexpr@(L _ expr) = do docAlt [ docSeq $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] - ++ line1 id docForceSingleline + ++ line1 docForceSingleline ++ join (lineR docForceSingleline) ++ lineDot + ++ [docSeparator] ++ lineN , docSetParSpacing $ docAddBaseY BrIndentRegular @@ -841,7 +843,7 @@ layoutExpr lexpr@(L _ expr) = do (docNodeAnnKW lexpr Nothing nameDoc) ( docNonBottomSpacing $ docLines - $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] + $ [docCols ColRecUpdate $ line1 (docAddBaseY BrIndentRegular)] ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) ++ [docSeq lineDot, docSeq lineN] ) -- 2.30.2 From 57c48f64c14481f9fcb0f82b36b19a73cea13ca7 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 4 Jun 2018 16:57:07 +0200 Subject: [PATCH 183/478] Apply inline config to module header (fixes #151) --- src-brittany/Main.hs | 11 ++--- src/Language/Haskell/Brittany/Internal.hs | 40 ++++++++++--------- .../Haskell/Brittany/Internal/Types.hs | 7 ++-- 3 files changed, 30 insertions(+), 28 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index ba66188..3652d47 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -248,7 +248,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx putErrorLn $ show left ExceptT.throwE 60 Right (anns, parsedSource, hasCPP) -> do - inlineConf <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of + (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of Left (err, input) -> do putErrorLn $ "Error: parse error in inline configuration:" @@ -257,6 +257,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx ExceptT.throwE 61 Right c -> -- trace (showTree c) $ pure c + let moduleConf = cZipWith fromOptionIdentity config inlineConf when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () @@ -265,15 +266,15 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx then do pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns) else do - let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack + let omitCheck = moduleConf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config inlineConf anns parsedSource - else liftIO $ pPrintModuleAndCheck config inlineConf anns parsedSource + then return $ pPrintModule moduleConf perItemConf anns parsedSource + else liftIO $ pPrintModuleAndCheck moduleConf perItemConf anns parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s let out = TextL.toStrict $ if hackAroundIncludes then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw else outRaw - out' <- if config & _conf_obfuscate & confUnpack + out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out pure $ (ews, out') diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 6bc70eb..182f3ed 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -71,7 +71,7 @@ data InlineConfigTarget extractCommentConfigs :: ExactPrint.Anns -> TopLevelDeclNameMap - -> Either (String, String) InlineConfig + -> Either (String, String) (CConfig Option, PerItemConfig) extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do let commentLiness = @@ -200,11 +200,10 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do _ -> False ] - pure $ InlineConfig - { _icd_perModule = perModule - , _icd_perBinding = perBinding - , _icd_perKey = perKey - } + pure + $ ( perModule + , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } + ) getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap @@ -256,17 +255,19 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do case parseResult of Left err -> throwE [ErrorInput err] Right x -> pure x - inlineConf <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + (inlineConf, perItemConf) <- + either (throwE . (: []) . uncurry ErrorMacroConfig) pure + $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + let moduleConfig = cZipWith fromOptionIdentity config inlineConf (errsWarns, outputTextL) <- do let omitCheck = - config + moduleConfig & _conf_errorHandling & _econf_omit_output_valid_check & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config inlineConf anns parsedSource - else lift $ pPrintModuleAndCheck config inlineConf anns parsedSource + then return $ pPrintModule moduleConfig perItemConf anns parsedSource + else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes @@ -284,7 +285,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorMacroConfig{} = 5 let hasErrors = - case config & _conf_errorHandling & _econf_Werror & confUnpack of + case moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack of False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) True -> not $ null errsWarns if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL @@ -297,7 +298,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do -- can occur. pPrintModule :: Config - -> InlineConfig + -> PerItemConfig -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) @@ -335,7 +336,7 @@ pPrintModule conf inlineConf anns parsedModule = -- if it does not. pPrintModuleAndCheck :: Config - -> InlineConfig + -> PerItemConfig -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) @@ -361,18 +362,20 @@ parsePrintModuleTests conf filename input = do case parseResult of Left (_ , s ) -> return $ Left $ "parsing error: " ++ s Right (anns, parsedModule) -> runExceptT $ do - inlineConf <- + (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of Left err -> throwE $ "error in inline config: " ++ show err Right x -> pure x + let moduleConf = cZipWith fromOptionIdentity conf inlineConf let omitCheck = conf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (errs, ltext) <- if omitCheck - then return $ pPrintModule conf inlineConf anns parsedModule - else lift $ pPrintModuleAndCheck conf inlineConf anns parsedModule + then return $ pPrintModule moduleConf perItemConf anns parsedModule + else + lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule if null errs then pure $ TextL.toStrict $ ltext else @@ -434,7 +437,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk - let inlineModConf = _icd_perModule inlineConf let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mBindingConfs = declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf @@ -448,7 +450,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do config <- mAsk let config' = cZipWith fromOptionIdentity config $ mconcat - (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) + (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index a28f940..221e1a9 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -28,9 +28,8 @@ import Data.Generics.Uniplate.Direct as Uniplate -data InlineConfig = InlineConfig - { _icd_perModule :: CConfig Option - , _icd_perBinding :: Map String (CConfig Option) +data PerItemConfig = PerItemConfig + { _icd_perBinding :: Map String (CConfig Option) , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option) } #if MIN_VERSION_ghc(8,2,0) @@ -38,7 +37,7 @@ data InlineConfig = InlineConfig #endif type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, InlineConfig, Config, ExactPrint.Anns] + '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] -- 2.30.2 From 6725d0e1198aa490cf482e3dcf75dffb5c682471 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 4 Jun 2018 17:06:23 +0200 Subject: [PATCH 184/478] Refactor/Auto-format Main, Brittany.Internal --- src-brittany/Main.hs | 427 +++++++++++++--------- src/Language/Haskell/Brittany/Internal.hs | 135 +++---- 2 files changed, 324 insertions(+), 238 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 3652d47..68f846a 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -6,22 +6,24 @@ module Main where #include "prelude.inc" -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate + as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Data.Monoid -import Text.Read (Read(..)) -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Data.Text.Lazy.Builder as Text.Builder +import Text.Read ( Read(..) ) +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Data.Text.Lazy.Builder as Text.Builder -import Control.Monad (zipWithM) +import Control.Monad ( zipWithM ) import Data.CZipWith -import qualified Debug.Trace as Trace +import qualified Debug.Trace as Trace import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal @@ -30,19 +32,20 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Obfuscation -import qualified Text.PrettyPrint as PP +import qualified Text.PrettyPrint as PP import DataTreePrint import UI.Butcher.Monadic import qualified System.Exit -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Paths_brittany -import Paths_brittany data WriteMode = Display | Inplace @@ -73,16 +76,16 @@ helpDoc = PP.vcat $ List.intersperse ] , parDoc $ "Example invocations:" , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany" - , PP.nest 2 $ PP.text "read from stdin, output to stdout" - ] + [ PP.text "brittany" + , PP.nest 2 $ PP.text "read from stdin, output to stdout" + ] , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" - , PP.nest 2 $ PP.vcat - [ PP.text "run on all modules in current directory (no backup!)" - , PP.text "4 spaces indentation" - ] + [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" + , PP.nest 2 $ PP.vcat + [ PP.text "run on all modules in current directory (no backup!)" + , PP.text "4 spaces indentation" ] + ] , parDocW [ "This program is written carefully and contains safeguards to ensure" , "the output is syntactically valid and that no comments are removed." @@ -93,9 +96,14 @@ helpDoc = PP.vcat $ List.intersperse , "codebase without having backups." ] , parDoc $ "There is NO WARRANTY, to the extent permitted by law." - , parDocW ["This program is free software released under the AGPLv3.", "For details use the --license flag."] + , parDocW + [ "This program is free software released under the AGPLv3." + , "For details use the --license flag." + ] , parDoc $ "See https://github.com/lspitzner/brittany" - , parDoc $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" + , parDoc + $ "Please report bugs at" + ++ " https://github.com/lspitzner/brittany/issues" ] licenseDoc :: PP.Doc @@ -130,29 +138,39 @@ mainCmdParser helpDesc = do addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] mempty + configPaths <- addFlagStringParams "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] - (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source") - _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]") - writeMode <- addFlagReadParam + (flagHelp $ parDoc + "suppress the regular output, i.e. the transformed haskell source" + ) + _verbosity <- addSimpleCountFlag + "v" + ["verbose"] + (flagHelp $ parDoc "[currently without effect; TODO]") + writeMode <- addFlagReadParam "" ["write-mode"] "(display|inplace)" - ( flagHelp - ( PP.vcat + ( flagHelp + (PP.vcat [ PP.text "display: output for any input(s) goes to stdout" , PP.text "inplace: override respective input file (without backup!)" ] ) Data.Monoid.<> flagDefault Display ) - inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files") + inputParams <- addParamNoFlagStrings + "PATH" + (paramHelpStr "paths to input/inout haskell source files") reorderStop addCmdImpl $ void $ do when printLicense $ do @@ -165,29 +183,39 @@ mainCmdParser helpDesc = do putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do - liftIO $ putStrLn $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } $ ppHelpShallow helpDesc + liftIO + $ putStrLn + $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } + $ ppHelpShallow helpDesc System.Exit.exitSuccess - let inputPaths = if null inputParams then [Nothing] else map Just inputParams + let inputPaths = + if null inputParams then [Nothing] else map Just inputParams let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths + Display -> repeat Nothing + Inplace -> inputPaths configsToLoad <- liftIO $ if null configPaths - then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths + then + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths - config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x - when (config & _conf_debug & _dconf_dump_config & confUnpack) $ - trace (showConfigYaml config) $ return () + config <- + runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) + >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + when (config & _conf_debug & _dconf_dump_config & confUnpack) + $ trace (showConfigYaml config) + $ return () - results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths + results <- zipWithM (coreIO putStrErrLn config suppressOutput) + inputPaths + outputPaths case results of xs | all Data.Either.isRight xs -> pure () [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) -- | The main IO parts for the default mode of operation, and after commandline @@ -202,25 +230,32 @@ coreIO -> 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 = ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - -- there is a good of code duplication between the following code and the - -- `pureModuleTransform` function. Unfortunately, there are also a good - -- amount of slight differences: This module is a bit more verbose, and - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- the flag will do the following: insert a marker string - -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - -- The flag is intentionally misspelled to prevent clashing with - -- inline-config stuff. - let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = (config & _conf_roundtrip_exactprint_only & confUnpack) - || (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack) - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags +coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = + ExceptT.runExceptT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + -- there is a good of code duplication between the following code and the + -- `pureModuleTransform` function. Unfortunately, there are also a good + -- amount of slight differences: This module is a bit more verbose, and + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- the flag will do the following: insert a marker string + -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + -- The flag is intentionally misspelled to prevent clashing with + -- inline-config stuff. + let hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags then case cppMode of CPPModeAbort -> do return $ Left "Encountered -XCPP. Aborting." @@ -233,118 +268,158 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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 "-- BRITANY_INCLUDE_HACK " ++ s else s - let hackTransform = - if hackAroundIncludes && not exactprintOnly then List.intercalate "\n" . fmap hackF . lines' else id - inputString <- liftIO $ System.IO.hGetContents System.IO.stdin - 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 - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of - Left (err, input) -> do - putErrorLn - $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - ExceptT.throwE 61 - Right c -> -- trace (showTree c) $ - pure c - let moduleConf = cZipWith fromOptionIdentity config inlineConf - when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - (errsWarns, outSText) <- do - if exactprintOnly - then do - pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns) - else do - let omitCheck = moduleConf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf perItemConf anns parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s - let out = TextL.toStrict $ if hackAroundIncludes - then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw + 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 "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id + inputString <- liftIO $ System.IO.hGetContents System.IO.stdin + 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 + ExceptT.throwE 60 + Right (anns, parsedSource, hasCPP) -> do + (inlineConf, perItemConf) <- + case + extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + of + Left (err, input) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + ExceptT.throwE 61 + Right c -> -- trace (showTree c) $ + pure c + let moduleConf = cZipWith fromOptionIdentity config inlineConf + when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + (errsWarns, outSText) <- do + if exactprintOnly + then do + pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns) + else do + let omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return + $ pPrintModule moduleConf perItemConf anns parsedSource + else liftIO $ pPrintModuleAndCheck moduleConf + perItemConf + anns + parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let + out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ fmap hackF + $ TextL.splitOn (TextL.pack "\n") outRaw else outRaw - out' <- if moduleConf & _conf_obfuscate & confUnpack - then lift $ obfuscate out - else pure out - pure $ (ews, out') - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - when (not $ null errsWarns) $ do - let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{}:_) -> do - putErrorLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." - (ErrorInput str:_) -> do - putErrorLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{}:_) -> do - putErrorLn $ "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 some of the comments" - ++ " present in the input haskell source file." - putErrorLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" - (ErrorMacroConfig err input:_) -> do - putErrorLn - $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - [] -> error "cannot happen" - -- TODO: don't output anything when there are errors unless user - -- adds some override? - let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack + out' <- if moduleConf & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out') + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + when (not $ null errsWarns) $ do + let groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns + groupedErrsWarns `forM_` \case + (ErrorOutputCheck{} : _) -> do + putErrorLn + $ "ERROR: brittany pretty printer" + ++ " returned syntactically invalid result." + (ErrorInput str : _) -> do + putErrorLn $ "ERROR: parse error: " ++ str + uns@(ErrorUnknownNode{} : _) -> do + putErrorLn $ "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 some of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> error "cannot happen (TM)" + (ErrorMacroConfig err input : _) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let + hasErrors = + case config & _conf_errorHandling & _econf_Werror & confUnpack of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + outputOnErrs = + config + & _conf_errorHandling + & _econf_produceOutputOnErrors + & confUnpack shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) - when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - isIdentical <- case inputPathM of - Nothing -> pure False - Just path -> do - (== outSText) <$> Text.IO.readFile path - -- The above means we read the file twice, but the - -- GHC API does not really expose the source it - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> handle still open -> - -- write below crashes - evil.) - unless isIdentical $ Text.IO.writeFile p $ outSText + when shouldOutput + $ addTraceSep (_conf_debug config) + $ case outputPathM of + Nothing -> liftIO $ Text.IO.putStr $ outSText + Just p -> liftIO $ do + isIdentical <- case inputPathM of + Nothing -> pure False + Just path -> do + (== outSText) <$> Text.IO.readFile path + -- The above means we read the file twice, but the + -- GHC API does not really expose the source it + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> + -- handle still open -> write below crashes - evil.) + unless isIdentical $ Text.IO.writeFile p $ outSText - when hasErrors $ ExceptT.throwE 70 + when hasErrors $ ExceptT.throwE 70 where addTraceSep conf = if or diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 182f3ed..dd07051 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -17,8 +17,9 @@ where #include "prelude.inc" -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data @@ -27,9 +28,9 @@ import Data.HList.HList import qualified Data.Yaml import qualified Data.ByteString.Char8 import Data.CZipWith -import qualified UI.Butcher.Monadic as Butcher +import qualified UI.Butcher.Monadic as Butcher -import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Text.Lazy.Builder as Text.Builder import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types @@ -50,15 +51,19 @@ import Language.Haskell.Brittany.Internal.Transformations.Par import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC hiding (parseModule) -import ApiAnnotation ( AnnKeywordId(..) ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import SrcLoc ( SrcSpan ) +import qualified GHC as GHC + hiding ( parseModule ) +import ApiAnnotation ( AnnKeywordId(..) ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + ) +import SrcLoc ( SrcSpan ) import HsSyn -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC -import Data.Char (isSpace) +import Data.Char ( isSpace ) @@ -267,7 +272,8 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do & confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConfig perItemConf anns parsedSource - else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource + else lift + $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes @@ -303,30 +309,26 @@ pPrintModule -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf inlineConf anns parsedModule = - let - ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = - if Seq.null debugStrings - then - id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in - tracer $ (errs, Text.Builder.toLazyText out) + let ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do -- -- debugStrings `forM_` \s -> @@ -374,8 +376,8 @@ parsePrintModuleTests conf filename input = do .> confUnpack (errs, ltext) <- if omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedModule - else - lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule + else lift + $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule if null errs then pure $ TextL.toStrict $ ltext else @@ -426,7 +428,8 @@ parsePrintModuleTests conf filename input = do toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a toLocal conf anns m = do - (x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m + (x, write) <- + lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) pure x @@ -437,7 +440,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk - let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf + let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mBindingConfs = declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf filteredAnns <- mAsk @@ -449,8 +452,8 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do config <- mAsk - let config' = cZipWith fromOptionIdentity config $ mconcat - (catMaybes (mBindingConfs ++ [mDeclConf])) + let config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do @@ -486,13 +489,14 @@ getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] + _ -> [] -- Prints the information associated with the module annotation -- This includes the imports -ppPreamble :: GenLocated SrcSpan (HsModule GhcPs) - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] +ppPreamble + :: GenLocated SrcSpan (HsModule GhcPs) + -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap @@ -550,8 +554,8 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do if shouldReformatPreamble then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule @@ -567,14 +571,14 @@ _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _pat _ _ _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" layoutBriDoc :: BriDocNumbered -> PPMLocal () layoutBriDoc briDoc = do -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do -- Note that briDoc is BriDocNumbered, but state type is BriDoc. -- That's why the alt-transform looks a bit special here. traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw @@ -583,26 +587,33 @@ layoutBriDoc briDoc = do $ briDoc -- bridoc transformation: remove alts transformAlts briDoc >>= mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-alt" - _dconf_dump_bridoc_simpl_alt + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt -- bridoc transformation: float stuff in mGet >>= transformSimplifyFloating .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating -- bridoc transformation: par removal mGet >>= transformSimplifyPar .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-par" - _dconf_dump_bridoc_simpl_par + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par -- bridoc transformation: float stuff in mGet >>= transformSimplifyColumns .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-columns" - _dconf_dump_bridoc_simpl_columns + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns -- bridoc transformation: indent mGet >>= transformSimplifyIndent .> mSet - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-indent" - _dconf_dump_bridoc_simpl_indent - mGet >>= briDocToDoc .> traceIfDumpConf "bridoc final" - _dconf_dump_bridoc_final + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl @@ -627,6 +638,6 @@ layoutBriDoc briDoc = do let remainingComments = extractAllComments =<< Map.elems (_lstate_comments state') remainingComments - `forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell) + `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) return $ () -- 2.30.2 From 58167046585ba7962efcdae5d39e296bb3ea9028 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 4 Jun 2018 17:30:50 +0200 Subject: [PATCH 185/478] Fix import-hiding-paragraph with policy/=free (fixes #150) --- src-literatetests/10-tests.blt | 15 +++++++++++++++ src-literatetests/30-tests-context-free.blt | 16 ++++++++++++++++ .../Brittany/Internal/Layouters/Import.hs | 13 ++++++++----- 3 files changed, 39 insertions(+), 5 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 4919f3f..561bd64 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -734,6 +734,21 @@ import Test hiding ( ) import Test as T hiding ( ) +#test import-hiding-many +import Prelude as X + hiding ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) + #test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne ( ) import TestJustAbitToLongModuleNameLikeThisOneIs diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 3ecae6f..1cf082e 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -736,6 +736,22 @@ import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) import Test hiding () import Test as T hiding () +#test import-hiding-many +import Prelude as X + hiding + ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) + #test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne () import TestJustAbitToLongModuleNameLikeThisOneIs () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index aa4380f..10e8285 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -87,7 +87,10 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docSeq [hidDoc, layoutLLIEs True llies] + then docAlt + [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True llies] + , docPar hidDoc (layoutLLIEs True llies) + ] else do ieDs <- layoutAnnAndSepLLIEs llies docWrapNodeRest llies @@ -99,7 +102,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) + -- ..[hiding].( b ) [ieD] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq @@ -112,9 +115,9 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of addAlternative $ docPar (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - -- ..[hiding].( b - -- , b' - -- ) + -- ..[hiding].( b + -- , b' + -- ) (ieD:ieDs') -> docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) -- 2.30.2 From cc0718e96437321ece8f699b0d544ae1852be38e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 4 Jun 2018 18:18:44 +0200 Subject: [PATCH 186/478] Add indentation to import-hiding-paragraph --- src-literatetests/30-tests-context-free.blt | 24 +++++++++---------- .../Brittany/Internal/Layouters/Import.hs | 5 +++- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 1cf082e..0488ffc 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -739,18 +739,18 @@ import Test as T hiding () #test import-hiding-many import Prelude as X hiding - ( head - , init - , last - , maximum - , minimum - , pred - , read - , readFile - , succ - , tail - , undefined - ) + ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) #test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 10e8285..fc43ecf 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -89,7 +89,10 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of if compact then docAlt [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True llies] - , docPar hidDoc (layoutLLIEs True llies) + , let makeParIfHiding = if hiding + then docAddBaseY BrIndentRegular . docPar hidDoc + else id + in makeParIfHiding (layoutLLIEs True llies) ] else do ieDs <- layoutAnnAndSepLLIEs llies -- 2.30.2 From 5ed46121076e9cd4227734741d81c46e5b6f9a02 Mon Sep 17 00:00:00 2001 From: Adam Bergmark Date: Mon, 18 Jun 2018 03:14:39 +0200 Subject: [PATCH 187/478] Allow aeson 1.4.* --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index bc6764a..8e8dac7 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -100,7 +100,7 @@ library { , directory >=1.2.6.2 && <1.4 , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.9 - , aeson >=1.0.1.0 && <1.4 + , aeson >=1.0.1.0 && <1.5 , extra >=1.4.10 && <1.7 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 -- 2.30.2 From b37732d658278e4c3a2495dcc5f25f13e20de1fd Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 20 Jun 2018 22:33:46 +0200 Subject: [PATCH 188/478] Fix README.md installation command --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 235810a..3d5ac2c 100644 --- a/README.md +++ b/README.md @@ -76,7 +76,7 @@ log the size of the input, but _not_ the full input/output of requests.) # 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/ + cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/ ~~~~ - via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) -- 2.30.2 From 0bcab7c7b3fc021edf9222c2a6af5bde20a96319 Mon Sep 17 00:00:00 2001 From: Adam Bergmark Date: Mon, 18 Jun 2018 03:14:39 +0200 Subject: [PATCH 189/478] Allow aeson 1.4.* --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index bc6764a..8e8dac7 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -100,7 +100,7 @@ library { , directory >=1.2.6.2 && <1.4 , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.9 - , aeson >=1.0.1.0 && <1.4 + , aeson >=1.0.1.0 && <1.5 , extra >=1.4.10 && <1.7 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 -- 2.30.2 From 0b40dd7c32ec453f3f93f5f5d9b8327a5aee5938 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 4 Jul 2018 21:14:06 +0200 Subject: [PATCH 190/478] Fix deprecation warnings with latest versions of yaml --- src/Language/Haskell/Brittany/Internal.hs | 3 ++- src/Language/Haskell/Brittany/Internal/Config.hs | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index dd07051..5b6e7ef 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -122,7 +122,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do , \s -> "{" `isPrefixOf` dropWhile (== ' ') s , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) - . Data.Yaml.decode + . either (\_ -> Nothing) Just + . Data.Yaml.decodeEither' . Data.ByteString.Char8.pack -- TODO: use some proper utf8 encoder instead? ) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index e8ff5d6..2e63b49 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -235,14 +235,14 @@ readConfig path = do if exists then do contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of + fileConf <- case Data.Yaml.decodeEither' contents of Left e -> do liftIO $ putStrErrLn $ "error reading in brittany config from " ++ path ++ ":" - liftIO $ putStrErrLn e + liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) mzero Right x -> return x return $ Just fileConf -- 2.30.2 From ab389fe66fa34a7bef649cd996e5d81103ae4324 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 4 Jul 2018 21:21:22 +0200 Subject: [PATCH 191/478] Support for -XExplicitNamespaces and -XPatternSynonyms Properly round-trip export items of the forms "type OPERATOR" or "pattern SYNONYM" fixes #158 --- src-literatetests/14-extensions.blt | 14 +++++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 53 ++++++++++--------- 2 files changed, 43 insertions(+), 24 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 896d105..a1c930b 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -66,3 +66,17 @@ foo = do b <- g a return (a, b) +############################################################################### +## ExplicitNamespaces + PatternSynonyms +#test explicitnamespaces_patternsynonyms export +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +module Test (type (++), (++), pattern Foo) where + +#test explicitnamespaces_patternsynonyms import +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +import Test ( type (++) + , (++) + , pattern Foo + ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 4e5af9f..378de6e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -39,46 +39,51 @@ prepareName = id layoutIE :: ToBriDoc IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of - IEVar _ -> ien - IEThingAbs _ -> ien - IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEVar x -> layoutWrapped x + IEThingAbs x -> layoutWrapped x + IEThingAll _ -> docSeq [ienDoc, docLit $ Text.pack "(..)"] + IEThingWith _ (IEWildcard _) _ _ -> + docSeq [ienDoc, docLit $ Text.pack "(..)"] IEThingWith _ _ ns _ -> do hasComments <- hasAnyCommentsBelow lie runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq - $ [ien, docLit $ Text.pack "("] + $ [ienDoc, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR] - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar ien (layoutItems (splitFirstLast ns)) + addAlternative $ docAddBaseY BrIndentRegular $ docPar + ienDoc + (layoutItems (splitFirstLast ns)) where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] - layoutItems FirstLastEmpty = - docSetBaseY $ - docLines [docSeq [docParenLSep, docWrapNodeRest lie docEmpty] - ,docParenR - ] - layoutItems (FirstLastSingleton n) = - docSetBaseY $ docLines - [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR] - layoutItems (FirstLast n1 nMs nN) = - docSetBaseY $ docLines $ - [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] - ++ map layoutItem nMs - ++ [ docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN] - , docParenR - ] + layoutItems FirstLastEmpty = docSetBaseY $ docLines + [docSeq [docParenLSep, docWrapNodeRest lie docEmpty], docParenR] + layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines + [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR] + layoutItems (FirstLast n1 nMs nN) = + docSetBaseY + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + ++ map layoutItem nMs + ++ [docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN], docParenR] IEModuleContents n -> docSeq [ docLit $ Text.pack "module" , docSeparator , docLit . Text.pack . moduleNameString $ unLoc n ] _ -> docEmpty - where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) + where + ienDoc = docLit =<< lrdrNameToTextAnn (ieName <$> lie) + layoutWrapped = \case + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEPattern n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "pattern " <> name + L _ (IEType n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "type " <> name -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation -- 2.30.2 From d01572ecf4d4bf5955749239cf24102f985f6f28 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 4 Jul 2018 22:04:45 +0200 Subject: [PATCH 192/478] Switch CI to use ghc-8.4.3 instead of 8.4.1 --- .travis.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 46b2763..d8fec94 100644 --- a/.travis.yml +++ b/.travis.yml @@ -76,9 +76,9 @@ matrix: - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.2.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.4.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.4.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.4.3 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.4.3" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. -- 2.30.2 From 95f42061d2afd86aef202788a7e451d0bfe91e2c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 4 Jul 2018 22:42:20 +0200 Subject: [PATCH 193/478] Fixup for the fix of ExplicitNames/PatternSynonyms for ghc-8.0 --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 378de6e..56462b5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -39,8 +39,8 @@ prepareName = id layoutIE :: ToBriDoc IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of - IEVar x -> layoutWrapped x - IEThingAbs x -> layoutWrapped x + IEVar x -> layoutWrapped lie x + IEThingAbs x -> layoutWrapped lie x IEThingAll _ -> docSeq [ienDoc, docLit $ Text.pack "(..)"] IEThingWith _ (IEWildcard _) _ _ -> docSeq [ienDoc, docLit $ Text.pack "(..)"] @@ -76,7 +76,8 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where ienDoc = docLit =<< lrdrNameToTextAnn (ieName <$> lie) - layoutWrapped = \case +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2, 8.4, .. */ + layoutWrapped _ = \case L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEPattern n) -> do name <- lrdrNameToTextAnn n @@ -84,6 +85,16 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of L _ (IEType n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "type " <> name +#else /* ghc-8.0 */ + layoutWrapped outer n = do + name <- lrdrNameToTextAnn n + hasType <- hasAnnKeyword n AnnType + hasPattern <- hasAnnKeyword outer AnnPattern + docLit $ if + | hasType -> Text.pack "type (" <> name <> Text.pack ")" + | hasPattern -> Text.pack "pattern " <> name + | otherwise -> name +#endif -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation -- 2.30.2 From 3c5670d5cdb9373e18ef9588729a38a7a9f81534 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Jul 2018 21:31:28 +0200 Subject: [PATCH 194/478] Fix layouting for OpApps with comments (fixes 159) --- src-literatetests/15-regressions.blt | 7 ++++++ .../Brittany/Internal/LayouterBasics.hs | 16 +++++++++++++ .../Brittany/Internal/Layouters/Expr.hs | 23 +++++++++++++++---- .../Brittany/Internal/Transformations/Alt.hs | 10 ++++++-- 4 files changed, 49 insertions(+), 7 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index e066ca4..7e303cc 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -630,3 +630,10 @@ dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) + +#test issue 159 +spec = do + it "creates a snapshot at the given level" . withGraph runDB $ do + lift $ do + studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x + elaSnapshotReadingLevel snapshot `shouldBe` 12 diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 191581c..d5aac63 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -57,6 +57,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , allocateNode , docSharedWrapper , hasAnyCommentsBelow + , hasAnyCommentsConnected , hasAnnKeyword ) where @@ -266,6 +267,9 @@ filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +-- | True if there are any comments that are +-- a) connected to any node below (in AST sense) the given node AND +-- b) after (in source code order) the node. hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow ast@(L l _) = do anns <- filterAnns ast <$> mAsk @@ -275,6 +279,18 @@ hasAnyCommentsBelow ast@(L l _) = do $ Map.elems $ anns +-- | True if there are any comments that are +-- connected to any node below (in AST sense) the given node +hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsConnected ast = do + anns <- filterAnns ast <$> mAsk + return + $ not + $ null + $ (=<<) extractAllComments + $ Map.elems + $ anns + hasAnnKeyword :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) => Located a diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 4ee0920..0aca344 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -236,14 +236,21 @@ layoutExpr lexpr@(L _ expr) = do ] opLastDoc <- docSharedWrapper layoutExpr expOp expLastDoc <- docSharedWrapper layoutExpr expRight - hasComments <- hasAnyCommentsBelow lexpr + allowSinglelinePar <- do + hasComLeft <- hasAnyCommentsConnected expLeft + hasComOp <- hasAnyCommentsConnected expOp + pure $ not hasComLeft && not hasComOp let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True runFilteredAlternative $ do - addAlternativeCond (not hasComments) + -- > one + two + three + -- or + -- > one + two + case x of + -- > _ -> three + addAlternativeCond allowSinglelinePar $ docSeq [ appSep $ docForceSingleline leftOperandDoc , docSeq @@ -265,6 +272,9 @@ layoutExpr lexpr@(L _ expr) = do -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ) + -- > one + -- > + two + -- > + three addAlternative $ docPar leftOperandDoc @@ -300,7 +310,10 @@ layoutExpr lexpr@(L _ expr) = do addAlternative $ docAddBaseY BrIndentRegular $ docPar - expDocLeft + expDocLeft -- TODO: this is not forced to single-line, which has + -- certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. ( docForceSingleline $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] ) @@ -773,7 +786,7 @@ layoutExpr lexpr@(L _ expr) = do [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - docAlt + docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free [ docSeq $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 docForceSingleline @@ -829,7 +842,7 @@ layoutExpr lexpr@(L _ expr) = do [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - docAlt + docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free [ docSeq $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 docForceSingleline diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 053e032..f247170 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -440,7 +440,11 @@ getSpacing !bridoc = rec bridoc BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> rec bd + BDFForceMultiline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> LineModeInvalid + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case @@ -686,7 +690,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFAlt alts -> do r <- rec `mapM` alts return $ filterAndLimit =<< r - BDFForceMultiline bd -> rec bd + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs BDFForceSingleline bd -> do mVs <- filterAndLimit <$> rec bd return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs -- 2.30.2 From ab27825b7bfc9a8a4df430dd7e7fc326abae5af7 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 6 Jul 2018 22:41:31 +0200 Subject: [PATCH 195/478] Core layouting algo improvement (non-bottom more effective) During alt-transform, when gather spacings, previously we tracked different non-bottom spacings separately even though they would be treated in the same way during any future transformations (apart from certain exceptions that don't practically give better results). Instead we now merge such spacings into one, giving more space for other spacings when pruning to the spacings limit. --- src-literatetests/15-regressions.blt | 14 ++++++++ .../Brittany/Internal/Transformations/Alt.hs | 35 ++++++++++++++++--- 2 files changed, 44 insertions(+), 5 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 7e303cc..6d0be5d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -637,3 +637,17 @@ spec = do lift $ do studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x elaSnapshotReadingLevel snapshot `shouldBe` 12 + +#test non-bottom-specialcase-altsearch +jaicyhHumzo btrKpeyiFej mava = do + m :: VtohxeRgpmgsu <- qloxIfiq mava + case m of + ZumnaoFujayerIswadabo kkecm chlixxag -> do + imomue <- ozisduRaqiseSBAob btrKpeyiFej $ \s -> + case MizA.pigevo kkecm (_tc_gulawulu s) of + Ebocaba -> + ( s { _tc_gulawulu = MizA.jxariu kkecm rwuRqxzhjo (_tc_gulawulu s) } + , Gtzvonm + ) + Xcde{} -> (s, Pioemav) + pure imomue diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index f247170..218f596 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -545,6 +545,8 @@ getSpacing !bridoc = rec bridoc VerticalSpacingParNone -> 0 VerticalSpacingParAlways i -> i +data SpecialCompare = Unequal | Smaller | Bigger + getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) @@ -571,6 +573,29 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParNone -> True VerticalSpacingParSome i -> i <= colMax VerticalSpacingParAlways{} -> True + let specialCompare vs1 vs2 = + if ( (_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr let -- the standard function used to enforce a constant upper bound -- on the number of elements returned for each node. Should be -- applied whenever in a parent the combination of spacings from @@ -579,11 +604,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc filterAndLimit = take limit -- prune so we always consider a constant -- amount of spacings per node of the BriDoc. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . List.nub + . specialNub -- In the end we want to know if there is at least -- one valid spacing for any alternative. -- If there are duplicates in the list, then these @@ -605,6 +626,10 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc -- layouts when we can than take non-optimal layouts -- just to be consistent with other cases where -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. . preFilterLimit result <- case brdc of -- BDWrapAnnKey _annKey bd -> rec bd -- 2.30.2 From 4497fa927fc77a41f49ee385af4c35f391cc5a7f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 6 Jul 2018 22:57:33 +0200 Subject: [PATCH 196/478] Add a comment about one superfluous docSetParSpacing --- .../Haskell/Brittany/Internal/Layouters/Expr.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 0aca344..7cbd3c2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -177,10 +177,13 @@ layoutExpr lexpr@(L _ expr) = do , -- func argline1 -- arglines -- e.g. - -- func if x - -- then 1 - -- else 2 - docSetParSpacing + -- func Abc + -- { member1 = True + -- , member2 = 13 + -- } + docSetParSpacing -- this is most likely superfluous because + -- this is a sequence of a one-line and a par-space + -- anyways, so it is _always_ par-spaced. $ docAddBaseY BrIndentRegular $ docSeq [ appSep $ docForceSingleline expDoc1 -- 2.30.2 From 0c324b19ecf78e7040ef1e6fd09a485faefb905b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Christian=20Kj=C3=A6r?= Date: Mon, 9 Jul 2018 14:29:49 +0200 Subject: [PATCH 197/478] Add note about Atom editor integration in README, fixes #62 --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 3d5ac2c..2afc464 100644 --- a/README.md +++ b/README.md @@ -109,6 +109,8 @@ log the size of the input, but _not_ the full input/output of requests.) #### Neovim / Vim 8 The [Neoformat](https://github.com/sbdchd/neoformat) plugin comes with support for brittany built in. +#### Atom + [Atom Beautify](https://atom.io/packages/atom-beautify) supports brittany as a formatter for Haskell. Since the default formatter is set to hindent, you will need to change this setting to brittany, after installing the extension. # Usage -- 2.30.2 From c303e45f16d8b4b93c4bf8ac48d579ae87ad668a Mon Sep 17 00:00:00 2001 From: Robert Date: Mon, 6 Aug 2018 14:05:10 +0200 Subject: [PATCH 198/478] Fix a brittany misspelling --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 2afc464..d42d085 100644 --- a/README.md +++ b/README.md @@ -88,7 +88,7 @@ log the size of the input, but _not_ the full input/output of requests.) (earlier ltss did not include `brittany` yet, but the repo should contain a `stack.yaml` that works with ghc-8.0.) -- on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/) +- on ArchLinux via [the brittany AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`: ~~~~.sh aura -A brittany -- 2.30.2 From a5a24b4220ec926696dd2ea0b3a3a87f6eeaa3e5 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Fri, 10 Aug 2018 09:49:47 +0100 Subject: [PATCH 199/478] Fix imports of type operators. Previously, we could only import a type operator with no subsequent list, i.e. import Foo ( (:.) ) was fine, but import Foo ( (:.)(..) ) import Foo ( (:.)((:.) ) import Foo ( (:.)(A, b) ) would all break. Brittany would attempt to output them as import Foo ( :.(..) ) import Foo ( :.((:.) ) import Foo ( :.(A, b) ) I believe the problem was that although `ieName <$> lie` was returning an `IEWrappedName` with the same contents as used in `layoutWrapped`, it had different location annotations; and the parentheses are apparently saved in the location annotations. --- src-literatetests/10-tests.blt | 3 +++ src-literatetests/14-extensions.blt | 1 + .../Haskell/Brittany/Internal/Layouters/IE.hs | 13 ++++++------- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 561bd64..db6cbde 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -727,6 +727,9 @@ import Test ( T , T5(T5, t5) , T6((<|>)) , (+) + , (:.) + , (:.)(..) + , (:.)(T7, (:.), t7) ) #test hiding diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index a1c930b..0e71918 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -79,4 +79,5 @@ module Test (type (++), (++), pattern Foo) where import Test ( type (++) , (++) , pattern Foo + , pattern (:.) ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 56462b5..42329cf 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -41,19 +41,19 @@ layoutIE :: ToBriDoc IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEVar x -> layoutWrapped lie x IEThingAbs x -> layoutWrapped lie x - IEThingAll _ -> docSeq [ienDoc, docLit $ Text.pack "(..)"] - IEThingWith _ (IEWildcard _) _ _ -> - docSeq [ienDoc, docLit $ Text.pack "(..)"] - IEThingWith _ _ ns _ -> do + IEThingAll x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] + IEThingWith x (IEWildcard _) _ _ -> + docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] + IEThingWith x _ ns _ -> do hasComments <- hasAnyCommentsBelow lie runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq - $ [ienDoc, docLit $ Text.pack "("] + $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR] addAlternative $ docAddBaseY BrIndentRegular $ docPar - ienDoc + (layoutWrapped lie x) (layoutItems (splitFirstLast ns)) where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName @@ -75,7 +75,6 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of ] _ -> docEmpty where - ienDoc = docLit =<< lrdrNameToTextAnn (ieName <$> lie) #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2, 8.4, .. */ layoutWrapped _ = \case L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n -- 2.30.2 From 8c5cce50709d6c0e41aed13df808a36ce13df4a4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 20 Aug 2018 21:19:10 +0200 Subject: [PATCH 200/478] Prevent package environment file GHC API stupidities This fixes the code-path for the commandline interface (unfortunately not covered by our testsuite). The other code-path should be covered by the changes in https://github.com/alanz/ghc-exactprint/pull/68. --- .../Haskell/Brittany/Internal/ExactPrintUtils.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 375c779..7c582f1 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -70,8 +70,14 @@ parseModuleWithCpp parseModuleWithCpp cpp opts args fp dynCheck = ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ GHC.getSessionDynFlags - (dflags1, leftover, warnings) <- lift - $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) + (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine + dflags0 + (GHC.noLoc <$> ("-hide-all-packages" : args)) + -- that we pass -hide-all-packages here is a duplication, because + -- ExactPrint.initDynFlags also does it, but necessary because of + -- stupid and careless GHC API design. We explicitly want to pass + -- our args before calling that, so this is what we do. Should be + -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063. void $ lift $ GHC.setSessionDynFlags dflags1 dflags2 <- lift $ ExactPrint.initDynFlags fp when (not $ null leftover) -- 2.30.2 From 3729a57196279c81cf5bd5ae6dde444a86f03460 Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Tue, 11 Sep 2018 01:25:35 -0400 Subject: [PATCH 201/478] Add check mode for use by test suites This mode makes no changes to files, but returns 0 (success) when no changes would be made and 1 (failure) when changes would be made. --- src-brittany/Main.hs | 68 +++++++++++++++++++++++++++++--------------- 1 file changed, 45 insertions(+), 23 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 68f846a..4581adf 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -156,6 +156,16 @@ mainCmdParser helpDesc = do "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]") + checkMode <- addSimpleBoolFlag + "c" + ["check-mode"] + (flagHelp + (PP.vcat + [ PP.text "check for changes but do not write them out" + , PP.text "exits with code 0 if no changes necessary, 1 otherwise" + ] + ) + ) writeMode <- addFlagReadParam "" ["write-mode"] @@ -209,14 +219,21 @@ mainCmdParser helpDesc = do $ trace (showConfigYaml config) $ return () - results <- zipWithM (coreIO putStrErrLn config suppressOutput) + results <- zipWithM (coreIO putStrErrLn config (suppressOutput || checkMode)) inputPaths outputPaths - case results of - xs | all Data.Either.isRight xs -> pure () - [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + if checkMode + then when (any (==Changes) (Data.Either.rights results)) $ + System.Exit.exitWith (System.Exit.ExitFailure 1) + else case results of + xs | all Data.Either.isRight xs -> pure () + [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + + +data ChangeStatus = Changes | NoChanges + deriving (Eq) -- | The main IO parts for the default mode of operation, and after commandline -- and config stuff is processed. @@ -229,7 +246,7 @@ coreIO -- 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. + -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runExceptT $ do let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () @@ -268,7 +285,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = return $ Right True CPPModeNowarn -> return $ Right True else return $ Right False - parseResult <- case inputPathM of + (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic let hackF s = if "#include" `isPrefixOf` s @@ -278,11 +295,22 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = 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 + parseRes <- liftIO $ parseModuleFromString ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) + return (parseRes, Text.pack inputString) + Just p -> liftIO $ do + parseRes <- parseModule ghcOptions p cppCheckFunc + inputText <- Text.IO.readFile p + -- The above means we read the file twice, but the + -- GHC API does not really expose the source it + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> + -- handle still open -> write below crashes - evil.) + return (parseRes, inputText) case parseResult of Left left -> do putErrorLn "parse error:" @@ -401,25 +429,19 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = & confUnpack shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) + let noChanges = outSText == originalContents when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText Just p -> liftIO $ do - isIdentical <- case inputPathM of - Nothing -> pure False - Just path -> do - (== outSText) <$> Text.IO.readFile path - -- The above means we read the file twice, but the - -- GHC API does not really expose the source it - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> - -- handle still open -> write below crashes - evil.) + let isIdentical = case inputPathM of + Nothing -> False + Just _ -> noChanges unless isIdentical $ Text.IO.writeFile p $ outSText when hasErrors $ ExceptT.throwE 70 + return (if noChanges then NoChanges else Changes) where addTraceSep conf = if or -- 2.30.2 From 989364093cfb1b4757e14ca4ffe8ef47d9e69b43 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 12 Sep 2018 22:01:43 +0200 Subject: [PATCH 202/478] Allow ghc-exactprint 0.5.7.1 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 8e8dac7..9da2898 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -86,7 +86,7 @@ library { { base >=4.9 && <4.12 , ghc >=8.0.1 && <8.5 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.6.0 && <0.5.7 + , ghc-exactprint >=0.5.6.0 && <0.5.8 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.6 , mtl >=2.2.1 && <2.3 -- 2.30.2 From 9ae790ede12f63cb2f7c5068831190bb3e415022 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 11 Sep 2018 20:32:31 +0200 Subject: [PATCH 203/478] Fix .travis script: Prevent duplicated build --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index d8fec94..675395a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -290,8 +290,8 @@ script: (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M -RTS") ;; canew) - better_wait cabal new-build -j$JOBS --disable-tests --disable-benchmarks - better_wait cabal new-build -j$JOBS --enable-tests --enable-benchmarks + better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks + better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks cabal new-test --ghc-options="-j1 +RTS -M500M -RTS" ;; esac -- 2.30.2 From 393258036f40de49a05b06a23e1cdb2290d3d9f4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 13 Sep 2018 22:09:12 +0200 Subject: [PATCH 204/478] Bump bounds to ghc-exactprint-0.5.8 to include pkg-env innoculation --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 9da2898..332ca76 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -86,7 +86,7 @@ library { { base >=4.9 && <4.12 , ghc >=8.0.1 && <8.5 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.6.0 && <0.5.8 + , ghc-exactprint >=0.5.8 && <0.5.9 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.6 , mtl >=2.2.1 && <2.3 -- 2.30.2 From 932cf70f9baff7b7870fa8744590d0de602f05f8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 13 Sep 2018 22:47:25 +0200 Subject: [PATCH 205/478] Fix stack yamls for ghc-exactprint bounds --- stack-8.0.2.yaml | 2 +- stack-8.2.2.yaml | 1 + stack.yaml | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index 849e301..80928db 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -6,7 +6,7 @@ extra-deps: - butcher-1.3.1.1 - data-tree-print-0.1.0.0 - deque-0.2 - - ghc-exactprint-0.5.6.0 + - ghc-exactprint-0.5.8.0 packages: - . \ No newline at end of file diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index b7f4c2b..1ce5fc3 100644 --- a/stack-8.2.2.yaml +++ b/stack-8.2.2.yaml @@ -3,6 +3,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 - butcher-1.3.1.1 + - ghc-exactprint-0.5.8.0 packages: - . diff --git a/stack.yaml b/stack.yaml index b7f4c2b..1ce5fc3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,6 +3,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 - butcher-1.3.1.1 + - ghc-exactprint-0.5.8.0 packages: - . -- 2.30.2 From 92a1d89983c94c708dcaec77cf8c40ab0700a3ee Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 16 Sep 2018 15:47:04 -0400 Subject: [PATCH 206/478] Consolidate record expression layouter Both record construction and record layouting have very similar constructions. These each had their own layouter with slightly different variations. Variations here lead to subtley different bugs in layout for nearly identicle syntactic forms. The record update logic is more advanced and respects `IndentPolicyLeft`. Instead of keeping these layouters distinct we can consolidate construction logic into the update logic. This results in a smaller volume of code and more uniform layouting of syntax for these simlilar forms. Record constructors with fields and wildcards are not included in this consolidation. A TODO has been left to handle this consolidation later. --- src-literatetests/15-regressions.blt | 7 +- src-literatetests/30-tests-context-free.blt | 16 + .../Haskell/Brittany/Internal/Backend.hs | 2 +- .../Brittany/Internal/Layouters/Expr.hs | 294 ++++++++---------- .../Haskell/Brittany/Internal/Types.hs | 4 +- 5 files changed, 152 insertions(+), 171 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 6d0be5d..080c15e 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -53,10 +53,9 @@ func = Foo #test record construction 3 func = do - Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } + Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } #test post-indent comment func = do diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 0488ffc..d5c4507 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -1378,6 +1378,22 @@ foo = cccc = () in foo +#test issue 176 + +record :: Record +record = Record + { rProperties = + [ "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + ] + } + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 6b38480..16a9362 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -527,7 +527,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do (BDCols ColGuardedBody _) -> True (BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True - (BDCols ColRecUpdate _) -> False + (BDCols ColRec _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False (BDCols ColApp{} _) -> True diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 7cbd3c2..92bcceb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -15,7 +15,7 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..), RdrName(..) ) +import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) import HsSyn import Name import qualified FastString @@ -750,67 +750,21 @@ layoutExpr lexpr@(L _ expr) = do ExplicitPArr{} -> do -- TODO briDocByExactInlineOnly "ExplicitPArr{}" lexpr - RecordCon lname _ _ (HsRecFields [] Nothing) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{" - , docLit $ Text.pack "}" - ] - RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do - -- TODO: the layouter for RecordUpd is slightly more clever. Should - -- probably copy the approach from there. + RecordCon lname _ _ (HsRecFields fields Nothing) -> do let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 wrapper = - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper x - ] - Nothing -> docEmpty - ] - let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , wrapper x - ] - Nothing -> docEmpty - ] - let lineN = - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free - [ docSeq - $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] - ++ line1 docForceSingleline - ++ join (lineR docForceSingleline) - ++ [docSeparator] - ++ lineN - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - ( docNonBottomSpacing - $ docLines - $ [docCols ColRecUpdate $ line1 (docAddBaseY BrIndentRegular)] - ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) - ++ [docSeq lineN] - ) - ] + rFs <- fields + `forM` \lfield@(L _ (HsRecField (L _ (FieldOcc lnameF _)) rFExpr pun)) -> do + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression indentPolicy lexpr nameDoc rFs + RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do let t = lrdrNameToText lname docWrapNode lname $ docLit $ t <> Text.pack " { .. }" RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do + -- TODO this should be consolidated into `recordExpression` let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do fExpDoc <- if pun @@ -859,19 +813,16 @@ layoutExpr lexpr@(L _ expr) = do (docNodeAnnKW lexpr Nothing nameDoc) ( docNonBottomSpacing $ docLines - $ [docCols ColRecUpdate $ line1 (docAddBaseY BrIndentRegular)] - ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular)) + $ [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)] + ++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular)) ++ [docSeq lineDot, docSeq lineN] ) ] RecordCon{} -> unknownNodeError "RecordCon with puns" lexpr - RecordUpd rExpr [] _ _ _ _ -> do + RecordUpd rExpr fields _ _ _ _ -> do rExprDoc <- docSharedWrapper layoutExpr rExpr - docSeq [rExprDoc, docLit $ Text.pack "{}"] - RecordUpd rExpr fields@(_:_) _ _ _ _ -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs@((rF1f, rF1n, rF1e):rFr) <- fields + rFs <- fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do rFExpDoc <- if pun then return Nothing @@ -879,106 +830,7 @@ layoutExpr lexpr@(L _ expr) = do return $ case ambName of Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - runFilteredAlternative $ do - -- container { fieldA = blub, fieldB = blub } - addAlternative - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc - , appSep $ docLit $ Text.pack "{" - , appSep $ docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr - , docLit $ Text.pack "}" - ] - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] - ] - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing rExprDoc) - (docNonBottomSpacing $ docLines $ let - expressionWrapper = case indentPolicy of - IndentPolicyLeft -> docForceParSpacing - IndentPolicyMultiple -> docForceParSpacing - IndentPolicyFree -> docSetBaseY - line1 = docCols ColRecUpdate - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield - $ docCols ColRecUpdate - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] - Nothing -> docEmpty - ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] - ) + recordExpression indentPolicy lexpr rExprDoc rFs #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #else /* ghc-8.0 */ @@ -1105,6 +957,120 @@ layoutExpr lexpr@(L _ expr) = do briDocByExactInlineOnly "ExplicitSum{}" lexpr #endif +recordExpression + :: (Data.Data.Data lExpr, Data.Data.Data name) + => IndentPolicy + -> GenLocated SrcSpan lExpr + -> ToBriDocM BriDocNumbered + -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] + -> ToBriDocM BriDocNumbered +recordExpression _ lexpr nameDoc [] = + docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = + runFilteredAlternative $ do + -- container { fieldA = blub, fieldB = blub } + addAlternative + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc + , appSep $ docLit $ Text.pack "{" + , appSep $ docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , docLit $ Text.pack "}" + ] + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep nameDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing $ docLines $ let + expressionWrapper = case indentPolicy of + IndentPolicyLeft -> docForceParSpacing + IndentPolicyMultiple -> docForceParSpacing + IndentPolicyFree -> docSetBaseY + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ) + #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ litBriDoc :: HsLit GhcPs -> BriDocFInt diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 221e1a9..ded4170 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -184,7 +184,7 @@ data ColSig -- expected to have exactly two columns | ColBindStmt | ColDoLet -- the non-indented variant - | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRec | ColListComp | ColList | ColApp Text @@ -410,7 +410,7 @@ briDocForceSpine bd = briDocSeqSpine bd `seq` bd data VerticalSpacingPar = VerticalSpacingParNone -- no indented lines - | VerticalSpacingParSome Int -- indented lines, requiring this much + | VerticalSpacingParSome Int -- indented lines, requiring this much -- vertical space at most | VerticalSpacingParAlways Int -- indented lines, requiring this much -- vertical space at most, but should -- 2.30.2 From b2795482faaea9cf3097d9ebda0b4593e7eb1f30 Mon Sep 17 00:00:00 2001 From: 5outh Date: Mon, 17 Sep 2018 14:32:20 -0400 Subject: [PATCH 207/478] Append input path name to UnknownNode errors --- src-brittany/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 4581adf..e56bede 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -285,6 +285,8 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = return $ Right True CPPModeNowarn -> return $ Right True else return $ Right False + let + inputPathName = maybe "stdin" (("file " <>) . show) inputPathM (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic @@ -382,7 +384,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str uns@(ErrorUnknownNode{} : _) -> do - putErrorLn $ "ERROR: encountered unknown syntactical constructs:" + putErrorLn $ "ERROR: encountered unknown syntactical constructs when parsing " <> inputPathName <> ":" uns `forM_` \case ErrorUnknownNode str ast -> do putErrorLn str -- 2.30.2 From 37e4225c492adf73007f05d16db88030c194ea72 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 18 Sep 2018 00:23:23 +0200 Subject: [PATCH 208/478] Include exact location when printing ErrorUnknownNode --- src-brittany/Main.hs | 13 ++++++++----- .../Brittany/Internal/LayouterBasics.hs | 5 ++++- .../Brittany/Internal/Layouters/Decl.hs | 19 ++++++++++--------- .../Haskell/Brittany/Internal/Types.hs | 4 ++-- 4 files changed, 24 insertions(+), 17 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index e56bede..8bbd111 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -15,6 +15,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Data.Map as Map import qualified Data.Monoid +import GHC ( GenLocated(L) ) +import Outputable ( Outputable(..) + , showSDocUnsafe + ) + import Text.Read ( Read(..) ) import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.ParserCombinators.ReadPrec as ReadPrec @@ -285,8 +290,6 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = return $ Right True CPPModeNowarn -> return $ Right True else return $ Right False - let - inputPathName = maybe "stdin" (("file " <>) . show) inputPathM (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic @@ -384,10 +387,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str uns@(ErrorUnknownNode{} : _) -> do - putErrorLn $ "ERROR: encountered unknown syntactical constructs when parsing " <> inputPathName <> ":" + putErrorLn $ "ERROR: encountered unknown syntactical constructs:" uns `forM_` \case - ErrorUnknownNode str ast -> do - putErrorLn str + ErrorUnknownNode str ast@(L loc _) -> do + putErrorLn $ str <> " at " <> showSDocUnsafe (ppr loc) when ( config & _conf_debug diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d5aac63..d4acb9f 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -694,7 +694,10 @@ docEnsureIndent docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError - :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered + :: Data.Data.Data ast + => String + -> GenLocated GHC.SrcSpan ast + -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do mTell [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index ee0596f..4d0440f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -27,7 +27,7 @@ import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils import GHC ( runGhc, GenLocated(L), moduleNameString ) -import SrcLoc ( SrcSpan ) +import SrcLoc ( SrcSpan, noSrcSpan ) import HsSyn import Name import BasicTypes ( InlinePragma(..) @@ -202,20 +202,21 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds (ValBindsIn bindlrs sigs) -> do - let - unordered - = [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered + let unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s return $ Just $ docs x@(HsValBinds (ValBindsOut _binds _lsigs)) -> -- i _think_ this case never occurs in non-processed ast - Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x - x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x - EmptyLocalBinds -> return $ Nothing + Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}" + (L noSrcSpan x) + x@(HsIPBinds _ipBinds) -> + Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x) + EmptyLocalBinds -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- parSpacing stuff.B diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 221e1a9..8d67edc 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -17,7 +17,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId, SrcSpan ) import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey ) @@ -134,7 +134,7 @@ data BrittanyError -- output and second the corresponding, ill-formed input. | LayoutWarning String -- ^ some warning - | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast + | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) -- ^ internal error: pretty-printing is not implemented for type of node -- in the syntax-tree | ErrorOutputCheck -- 2.30.2 From 9d7cecaa920df8e10f1b79fcb480cdb54faa8247 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Wed, 4 Apr 2018 09:26:59 +0100 Subject: [PATCH 209/478] Run tests in prallel --- brittany.cabal | 3 ++- src-literatetests/Main.hs | 7 +++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 332ca76..4d43fcc 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -335,8 +335,9 @@ test-suite littests ghc-options: { -Wall -fno-warn-unused-imports + -threaded -rtsopts - -with-rtsopts "-M2G" + -with-rtsopts "-M2G -N" } test-suite libinterfacetests diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 8f492d1..1196a56 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,12 +1,13 @@ {-# LANGUAGE QuasiQuotes #-} -module Main where +module Main (main) where #include "prelude.inc" import Test.Hspec +import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs ) import NeatInterpolation @@ -22,6 +23,7 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config import Data.Coerce ( coerce ) +import GHC.Conc ( getNumCapabilities ) import qualified Data.Text.IO as Text.IO import System.FilePath ( () ) @@ -48,7 +50,8 @@ main = do let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree - hspec $ do + jobs <- getNumCapabilities + hspecWith (defaultConfig { configConcurrentJobs = Just jobs }) $ do groups `forM_` \(groupname, tests) -> do describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do (if pend then before_ pending else id) -- 2.30.2 From 281d7a2f81698b265ce7ff8d559af2eeea8df484 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Tue, 18 Sep 2018 00:25:18 +0100 Subject: [PATCH 210/478] Lay out unboxed tuples with spaces This avoids clashes with names like foo# --- src-literatetests/15-regressions.blt | 10 +++++++ .../Brittany/Internal/Layouters/Expr.hs | 7 +++-- .../Brittany/Internal/Layouters/Pattern.hs | 30 +++++++++++-------- 3 files changed, 33 insertions(+), 14 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 080c15e..cb4ac5d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -650,3 +650,13 @@ jaicyhHumzo btrKpeyiFej mava = do ) Xcde{} -> (s, Pioemav) pure imomue + +#test unboxed-tuple and vanilla names +{-# LANGUAGE UnboxedTuples #-} +spanKey = case foo of + (# bar, baz #) -> (# baz, bar #) + +#test unboxed-tuple and hashed name +{-# LANGUAGE MagicHash, UnboxedTuples #-} +spanKey = case foo of + (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 92bcceb..96b739c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -371,8 +371,11 @@ layoutExpr lexpr@(L _ expr) = do $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)") + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> + ( docSeq [docLit $ Text.pack "(#", docSeparator] + , docSeq [docSeparator, docLit $ Text.pack "#)"] + ) case splitFirstLast argDocs of FirstLastEmpty -> docSeq [ openLit diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index c65b357..6c95e0b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -140,8 +140,8 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "(" ")" - Unboxed -> wrapPatListy args "(#" "#)" + Boxed -> wrapPatListy args "(" ")" False + Unboxed -> wrapPatListy args "(#" "#)" True AsPat asName asPat -> do -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") @@ -172,7 +172,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of ListPat elems _ _ -> -- [] -> expr1 -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 - wrapPatListy elems "[" "]" + wrapPatListy elems "[" "]" False BangPat pat1 -> do -- !nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "!") @@ -213,17 +213,23 @@ wrapPatListy :: [Located (Pat GhcPs)] -> String -> String + -> Bool -> ToBriDocM (Seq BriDocNumbered) -wrapPatListy elems start end = do +wrapPatListy elems start end padSeparators = do elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) - sDoc <- docLit $ Text.pack start - eDoc <- docLit $ Text.pack end case Seq.viewl elemDocs of Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end x1 Seq.:< rest -> do - rest' <- rest `forM` \bd -> docSeq - [ docLit $ Text.pack "," - , docSeparator - , return bd - ] - return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc + sDoc <- docLit $ Text.pack start + eDoc <- docLit $ Text.pack end + let sDoc' | padSeparators = docSeq [return sDoc, docSeparator] + | otherwise = return sDoc + eDoc' | padSeparators = docSeq [docSeparator, return eDoc] + | otherwise = return eDoc + sDoc'' <- sDoc' + eDoc'' <- eDoc' + rest' <- rest `forM` \bd -> docSeq + [ docCommaSep + , return bd + ] + return $ (sDoc'' Seq.<| x1 Seq.<| rest') Seq.|> eDoc'' -- 2.30.2 From 6898d3ef4459f9aed62556cf3eb76082a32c9869 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Tue, 18 Sep 2018 09:03:28 +0100 Subject: [PATCH 211/478] Lay out unboxed tuples in types --- src-literatetests/15-regressions.blt | 1 + .../Haskell/Brittany/Internal/Layouters/Type.hs | 17 +++++++++-------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index cb4ac5d..52306c1 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -658,5 +658,6 @@ spanKey = case foo of #test unboxed-tuple and hashed name {-# LANGUAGE MagicHash, UnboxedTuples #-} +spanKey :: _ -> (# Int#, Int# #) spanKey = case foo of (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index dfde7f5..2a8f0dd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -234,7 +234,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of list = List.tail cntxtDocs <&> \cntxtDoc -> docCols ColTyOpPrefix [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) + , docAddBaseY (BrIndentSpecial 2) $ cntxtDoc ] in docPar open $ docLines $ list ++ [close] @@ -407,17 +407,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs + let start = docSeq [docLit $ Text.pack "(#", docSeparator] + end = docSeq [docSeparator, docLit $ Text.pack "#)"] docAlt - [ docSeq $ [docLit $ Text.pack "(#"] + [ docSeq $ [start] ++ List.intersperse docCommaSep docs - ++ [docLit $ Text.pack "#)"] + ++ [end] , let - start = docCols ColTyOpPrefix [docLit $ Text.pack "(#", head docs] - lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] - end = docLit $ Text.pack "#)" + start' = docCols ColTyOpPrefix [start, head docs] + lines = List.tail docs <&> \d -> + docCols ColTyOpPrefix [docCommaSep, d] in docPar - (docAddBaseY (BrIndentSpecial 2) start) + (docAddBaseY (BrIndentSpecial 2) start') (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) ] HsOpTy{} -> -- TODO -- 2.30.2 From 9755db1d05ba30f95ea2d21d6be70006da1e1371 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Tue, 18 Sep 2018 09:12:35 +0100 Subject: [PATCH 212/478] Unify "(#", "#)" under single name, docParenHashL and docParenHashR --- src-literatetests/15-regressions.blt | 3 ++- .../Brittany/Internal/LayouterBasics.hs | 23 +++++++++++++++- .../Brittany/Internal/Layouters/Expr.hs | 5 +--- .../Brittany/Internal/Layouters/Pattern.hs | 26 +++++++------------ .../Brittany/Internal/Layouters/Type.hs | 4 +-- 5 files changed, 37 insertions(+), 24 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 52306c1..e7bf199 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -653,11 +653,12 @@ jaicyhHumzo btrKpeyiFej mava = do #test unboxed-tuple and vanilla names {-# LANGUAGE UnboxedTuples #-} +spanKey :: (# Int, Int #) -> (# Int, Int #) spanKey = case foo of (# bar, baz #) -> (# baz, bar #) #test unboxed-tuple and hashed name {-# LANGUAGE MagicHash, UnboxedTuples #-} -spanKey :: _ -> (# Int#, Int# #) +spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) spanKey = case foo of (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d5aac63..c6cd9ae 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -50,7 +50,12 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , appSep , docCommaSep , docParenLSep + , docParenL , docParenR + , docParenHashL + , docParenHashR + , docBracketL + , docBracketR , docTick , spacifyDocs , briDocMToPPM @@ -530,11 +535,27 @@ docCommaSep :: ToBriDocM BriDocNumbered docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered -docParenLSep = appSep $ docLit $ Text.pack "(" +docParenLSep = appSep docParenL + +docParenL :: ToBriDocM BriDocNumbered +docParenL = docLit $ Text.pack "(" docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" +docParenHashL :: ToBriDocM BriDocNumbered +docParenHashL = docSeq [docLit $ Text.pack "(#", docSeparator] + +docParenHashR :: ToBriDocM BriDocNumbered +docParenHashR = docSeq [docSeparator, docLit $ Text.pack "#)"] + +docBracketL :: ToBriDocM BriDocNumbered +docBracketL = docLit $ Text.pack "[" + +docBracketR :: ToBriDocM BriDocNumbered +docBracketR = docLit $ Text.pack "]" + + docTick :: ToBriDocM BriDocNumbered docTick = docLit $ Text.pack "'" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 96b739c..a486d3b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -372,10 +372,7 @@ layoutExpr lexpr@(L _ expr) = do hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> - ( docSeq [docLit $ Text.pack "(#", docSeparator] - , docSeq [docSeparator, docLit $ Text.pack "#)"] - ) + Unboxed -> (docParenHashL, docParenHashR) case splitFirstLast argDocs of FirstLastEmpty -> docSeq [ openLit diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 6c95e0b..6b8e750 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -140,8 +140,8 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "(" ")" False - Unboxed -> wrapPatListy args "(#" "#)" True + Boxed -> wrapPatListy args "()" docParenL docParenR + Unboxed -> wrapPatListy args "(##)" docParenHashL docParenHashR AsPat asName asPat -> do -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") @@ -172,7 +172,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of ListPat elems _ _ -> -- [] -> expr1 -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 - wrapPatListy elems "[" "]" False + wrapPatListy elems "[]" docBracketL docBracketR BangPat pat1 -> do -- !nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "!") @@ -212,24 +212,18 @@ wrapPatPrepend pat prepElem = do wrapPatListy :: [Located (Pat GhcPs)] -> String - -> String - -> Bool + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) -wrapPatListy elems start end padSeparators = do +wrapPatListy elems both start end = do elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) case Seq.viewl elemDocs of - Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end + Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both x1 Seq.:< rest -> do - sDoc <- docLit $ Text.pack start - eDoc <- docLit $ Text.pack end - let sDoc' | padSeparators = docSeq [return sDoc, docSeparator] - | otherwise = return sDoc - eDoc' | padSeparators = docSeq [docSeparator, return eDoc] - | otherwise = return eDoc - sDoc'' <- sDoc' - eDoc'' <- eDoc' + sDoc <- start + eDoc <- end rest' <- rest `forM` \bd -> docSeq [ docCommaSep , return bd ] - return $ (sDoc'' Seq.<| x1 Seq.<| rest') Seq.|> eDoc'' + return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 2a8f0dd..d50a10c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -407,8 +407,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs - let start = docSeq [docLit $ Text.pack "(#", docSeparator] - end = docSeq [docSeparator, docLit $ Text.pack "#)"] + let start = docParenHashL + end = docParenHashR docAlt [ docSeq $ [start] ++ List.intersperse docCommaSep docs -- 2.30.2 From 71efa549540ee085b7abe49a73b5dd95b97b3a4e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 23 Sep 2018 23:09:50 +0200 Subject: [PATCH 213/478] Move tests, minor Refactoring, Add comments --- src-literatetests/14-extensions.blt | 14 +++++++++++ src-literatetests/15-regressions.blt | 12 --------- .../Brittany/Internal/LayouterBasics.hs | 18 ++++++++----- .../Brittany/Internal/Layouters/Expr.hs | 2 +- .../Brittany/Internal/Layouters/Pattern.hs | 2 +- .../Brittany/Internal/Layouters/Type.hs | 25 +++++++++---------- 6 files changed, 40 insertions(+), 33 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 0e71918..9dc0378 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -81,3 +81,17 @@ import Test ( type (++) , pattern Foo , pattern (:.) ) + +############################################################################### +## UnboxedTuples + MagicHash +#test unboxed-tuple and vanilla names +{-# LANGUAGE UnboxedTuples #-} +spanKey :: (# Int, Int #) -> (# Int, Int #) +spanKey = case foo of + (# bar, baz #) -> (# baz, bar #) + +#test unboxed-tuple and hashed name +{-# LANGUAGE MagicHash, UnboxedTuples #-} +spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) +spanKey = case foo of + (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index e7bf199..080c15e 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -650,15 +650,3 @@ jaicyhHumzo btrKpeyiFej mava = do ) Xcde{} -> (s, Pioemav) pure imomue - -#test unboxed-tuple and vanilla names -{-# LANGUAGE UnboxedTuples #-} -spanKey :: (# Int, Int #) -> (# Int, Int #) -spanKey = case foo of - (# bar, baz #) -> (# baz, bar #) - -#test unboxed-tuple and hashed name -{-# LANGUAGE MagicHash, UnboxedTuples #-} -spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) -spanKey = case foo of - (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index c6cd9ae..a431855 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -52,8 +52,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docParenLSep , docParenL , docParenR - , docParenHashL - , docParenHashR + , docParenHashLSep + , docParenHashRSep , docBracketL , docBracketR , docTick @@ -537,17 +537,23 @@ docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered docParenLSep = appSep docParenL +-- TODO: we don't make consistent use of these (yet). However, I think the +-- most readable approach overall might be something else: define +-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. +-- I think those two would make the usage most readable. +-- lit "(" and appSep (lit "(") are understandable and short without +-- introducing a new top-level binding for all types of parentheses. docParenL :: ToBriDocM BriDocNumbered docParenL = docLit $ Text.pack "(" docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" -docParenHashL :: ToBriDocM BriDocNumbered -docParenHashL = docSeq [docLit $ Text.pack "(#", docSeparator] +docParenHashLSep :: ToBriDocM BriDocNumbered +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] -docParenHashR :: ToBriDocM BriDocNumbered -docParenHashR = docSeq [docSeparator, docLit $ Text.pack "#)"] +docParenHashRSep :: ToBriDocM BriDocNumbered +docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] docBracketL :: ToBriDocM BriDocNumbered docBracketL = docLit $ Text.pack "[" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a486d3b..1da80ae 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -372,7 +372,7 @@ layoutExpr lexpr@(L _ expr) = do hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashL, docParenHashR) + Unboxed -> (docParenHashLSep, docParenHashRSep) case splitFirstLast argDocs of FirstLastEmpty -> docSeq [ openLit diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 6b8e750..f409c30 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -141,7 +141,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of Boxed -> wrapPatListy args "()" docParenL docParenR - Unboxed -> wrapPatListy args "(##)" docParenHashL docParenHashR + Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep AsPat asName asPat -> do -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index d50a10c..5e97d5b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -392,33 +392,32 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of unitL = docLit $ Text.pack "()" simpleL = do docs <- docSharedWrapper layoutType `mapM` typs + let end = docLit $ Text.pack ")" + lines = List.tail docs <&> \d -> + docCols ColTyOpPrefix [docCommaSep, d] docAlt [ docSeq $ [docLit $ Text.pack "("] ++ List.intersperse docCommaSep (docForceSingleline <$> docs) - ++ [docLit $ Text.pack ")"] - , let - start = docCols ColTyOpPrefix [docParenLSep, head docs] - lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] - end = docLit $ Text.pack ")" + ++ [end] + , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] in docPar - (docAddBaseY (BrIndentSpecial 2) $ start) + (docAddBaseY (BrIndentSpecial 2) $ line1) (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs - let start = docParenHashL - end = docParenHashR + let start = docParenHashLSep + end = docParenHashRSep docAlt [ docSeq $ [start] - ++ List.intersperse docCommaSep docs - ++ [end] + ++ List.intersperse docCommaSep docs + ++ [end] , let - start' = docCols ColTyOpPrefix [start, head docs] + line1 = docCols ColTyOpPrefix [start, head docs] lines = List.tail docs <&> \d -> docCols ColTyOpPrefix [docCommaSep, d] in docPar - (docAddBaseY (BrIndentSpecial 2) start') + (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) ] HsOpTy{} -> -- TODO -- 2.30.2 From 04f441205d1b5b548e9b736a06e13b23440d1fdd Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 24 Sep 2018 00:09:01 +0200 Subject: [PATCH 214/478] Try fix travis new-build test failure with a -j1 --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 675395a..a67ec03 100644 --- a/.travis.yml +++ b/.travis.yml @@ -292,7 +292,7 @@ script: canew) better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks - cabal new-test --ghc-options="-j1 +RTS -M500M -RTS" + cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" ;; esac set +ex -- 2.30.2 From 66fd44058d28e579a9141ce051adb96963260bb7 Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Sat, 6 Oct 2018 19:01:13 -0400 Subject: [PATCH 215/478] Add instance formatting for simple case --- src-literatetests/10-tests.blt | 108 +++++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 147 +++++++++++++++--- stack-8.4.3.yaml | 4 + 3 files changed, 237 insertions(+), 22 deletions(-) create mode 100644 stack-8.4.3.yaml diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index db6cbde..1597c4b 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -905,3 +905,111 @@ import qualified Data.List as L -- Test import Test ( test ) + +############################################################################### +############################################################################### +############################################################################### +#group class.instance +############################################################################### +############################################################################### +############################################################################### + +#test simple-instance + +instance MyClass Int where + myMethod x = x + 1 + +#test simple-method-signature + +instance MyClass Int where + myMethod :: Int -> Int + myMethod x = x + 1 + +#test simple-long-method-signature + +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + +#test simple-two-methods + +instance MyClass Int where + myMethod x = x + 1 + myMethod2 x = x + 1 + +#test simple-two-signatures + +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + + myMethod2 :: Int -> Int + myMethod2 x = x + 1 + +#test simple-instance-comment + +-- | This instance should be commented on +instance MyClass Int where + + -- | This method is also comment-worthy + myMethod x = x + 1 + +#test instance-with-type-family + +instance MyClass Int where + type MyType = Int + + myMethod :: MyType -> Int + myMethod x = x + 1 + +#test instance-with-type-family-below-method + +instance MyClass Int where + + type MyType = String + + myMethod :: MyType -> Int + myMethod x = x + 1 + + type MyType = Int + +#test instance-with-data-family + +instance MyClass Int where + + -- | This data is very important + data MyData = IntData + { intData :: String + , intData2 :: Int + } + + myMethod :: MyData -> Int + myMethod = intData2 + +#test instance-with-data-family-below-method + +instance MyClass Int where + -- | This data is important + data MyData = Test Int Int + + myMethod :: MyData -> Int + myMethod = intData2 + + -- | This data is also important + data MyData2 = IntData + { intData :: String + -- ^ Interesting field + , intData2 :: Int + } diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 4d0440f..6ca5075 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -27,7 +27,7 @@ import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils import GHC ( runGhc, GenLocated(L), moduleNameString ) -import SrcLoc ( SrcSpan, noSrcSpan ) +import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name import BasicTypes ( InlinePragma(..) @@ -42,7 +42,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Bag ( mapBagM ) +import Bag ( mapBagM, bagToList, emptyBag ) @@ -65,16 +65,42 @@ layoutDecl d@(L loc decl) = case decl of (foldedAnnKeys d) False (Text.pack str) + InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d 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 + TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ #else /* ghc-8.0 */ - TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do + TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ #endif + InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> + docWrapNode lsig $ do + nameStr <- lrdrNameToTextAnn name + specStr <- specStringCompat lsig spec + let phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + let conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " + docLit + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + <> nameStr + <> Text.pack " #-}" +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ +#else /* ghc-8.0 */ + ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ +#endif + _ -> briDocByExactNoComment lsig -- TODO + where + layoutNamesAndType names typ = docWrapNode lsig $ do nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ @@ -112,24 +138,7 @@ layoutSig lsig@(L _loc sig) = case sig of ] ) ] - InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> - docWrapNode lsig $ do - nameStr <- lrdrNameToTextAnn name - specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " - docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) - <> nameStr - <> Text.pack " #-}" - _ -> briDocByExactNoComment lsig -- TODO + specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String @@ -585,3 +594,97 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ] ++ wherePartMultiLine + +-- | Layout an @instance@ declaration +-- +-- Layout signatures and bindings using the corresponding layouters from the +-- top-level. Layout the instance head, type family instances, and data family +-- instances using ExactPrint. +layoutClsInst :: ToBriDoc ClsInstDecl +layoutClsInst lcid@(L _ cid) = docLines + [ layoutInstanceHead + , docEnsureIndent BrIndentRegular + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) + ] + where + layoutInstanceHead :: ToBriDocM BriDocNumbered + layoutInstanceHead = + briDocByExactNoComment $ InstD . ClsInstD . removeChildren <$> lcid + + removeChildren :: ClsInstDecl p -> ClsInstDecl p + removeChildren c = c + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] + , cid_datafam_insts = [] + } + + -- | Like 'docLines', but sorts the lines based on location + docSortedLines + :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered + docSortedLines l = + allocateNode . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l + + layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) + layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig + + layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) + layoutAndLocateBind lbind@(L loc _) = + L loc <$> (joinBinds =<< layoutBind lbind) + + joinBinds + :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered + joinBinds = \case + Left ns -> docLines $ return <$> ns + Right n -> return n + + layoutAndLocateTyFamInsts + :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateTyFamInsts ltfid@(L loc _) = + L loc <$> layoutTyFamInstDecl ltfid + + -- | Send to ExactPrint then remove unecessary whitespace + layoutTyFamInstDecl :: ToBriDoc TyFamInstDecl + layoutTyFamInstDecl ltfid = + fmap stripWhitespace <$> briDocByExactNoComment ltfid + + layoutAndLocateDataFamInsts + :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateDataFamInsts ldfid@(L loc _) = + L loc <$> layoutDataFamInstDecl ldfid + + -- | Send to ExactPrint then remove unecessary whitespace + layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl + layoutDataFamInstDecl ldfid = + fmap stripWhitespace <$> briDocByExactNoComment ldfid + + -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations + stripWhitespace :: BriDocF f -> BriDocF f + stripWhitespace (BDFExternal ann anns b t) = + BDFExternal ann anns b $ stripWhitespace' t + stripWhitespace b = b + + -- | We strip the first newline from each @data@/@type@ declaration. If the + -- @data@/@type@ is the first declaration in the instance, then we also have + -- to strip whitespace from the start of the comments and the first line of + -- the declaration. This is brittle and should be replaced by proper + -- layouting + -- as soon as possible. + stripWhitespace' :: Text -> Text + stripWhitespace' t = + let + isTypeOrData t' = + Text.pack "type" + `Text.isPrefixOf` t' + || Text.pack "data" + `Text.isPrefixOf` t' + (comments, dat : rest) = + break (isTypeOrData . Text.stripStart) (Text.lines (Text.tail t)) + in Text.init + $ Text.unlines + $ fmap Text.stripStart comments + ++ (Text.stripStart dat : rest) diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml new file mode 100644 index 0000000..f925568 --- /dev/null +++ b/stack-8.4.3.yaml @@ -0,0 +1,4 @@ +resolver: lts-12.12 + +extra-deps: + - ghc-exactprint-0.5.8.1 -- 2.30.2 From 38216cdc02fa13bf2beca957f0ab49b8cb10cb4c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 11 Oct 2018 20:14:29 +0200 Subject: [PATCH 216/478] Add longer doc/Refactor stripWhitespace' --- .../Brittany/Internal/Layouters/Decl.hs | 66 ++++++++++++++----- 1 file changed, 48 insertions(+), 18 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 6ca5075..2ece967 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -668,23 +668,53 @@ layoutClsInst lcid@(L _ cid) = docLines BDFExternal ann anns b $ stripWhitespace' t stripWhitespace b = b - -- | We strip the first newline from each @data@/@type@ declaration. If the - -- @data@/@type@ is the first declaration in the instance, then we also have - -- to strip whitespace from the start of the comments and the first line of - -- the declaration. This is brittle and should be replaced by proper - -- layouting - -- as soon as possible. + -- | This fixes two issues of output coming from Exactprinting + -- associated (data) type decls. Firstly we place the output into docLines, + -- so one newline coming from Exactprint is superfluous, so we drop the + -- first (empty) line. The second issue is Exactprint indents the first + -- member in a strange fashion: + -- + -- input: + -- + -- > instance MyClass Int where + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- output of just exactprinting the associated data type syntax node + -- + -- > + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- To fix this, we strip whitespace from the start of the comments and the + -- first line of the declaration, stopping when we see "data" or "type" at + -- the start of a line. I.e., this function yields + -- + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- Downside apart from being a hacky and brittle fix is that this removes + -- possible additional indentation from comments before the first member. + -- + -- But the whole thing is just a temporary measure until brittany learns + -- to layout data/type decls. stripWhitespace' :: Text -> Text stripWhitespace' t = - let - isTypeOrData t' = - Text.pack "type" - `Text.isPrefixOf` t' - || Text.pack "data" - `Text.isPrefixOf` t' - (comments, dat : rest) = - break (isTypeOrData . Text.stripStart) (Text.lines (Text.tail t)) - in Text.init - $ Text.unlines - $ fmap Text.stripStart comments - ++ (Text.stripStart dat : rest) + Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t + where + go [] = [] + go (line1 : lineR) = case Text.stripStart line1 of + st | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR + isTypeOrData t' = + (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "data" `Text.isPrefixOf` t') -- 2.30.2 From 11dc30fbe16da80f1be4974a92d09b40243ee734 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 11 Oct 2018 22:20:21 +0200 Subject: [PATCH 217/478] Fix travis setup once more --- .travis.yml | 4 ++-- brittany.cabal | 8 ++++++++ src-literatetests/Main.hs | 4 +--- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index a67ec03..d148072 100644 --- a/.travis.yml +++ b/.travis.yml @@ -277,7 +277,7 @@ script: if [ -f configure.ac ]; then autoreconf -i; fi cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) - cabal test + time cabal test --ghc-options="-with-rtsopts -N1" ;; cabaldist) # cabal check @@ -292,7 +292,7 @@ script: canew) better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks - cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" + time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" ;; esac set +ex diff --git a/brittany.cabal b/brittany.cabal index 4d43fcc..da69f91 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -269,6 +269,10 @@ test-suite unittests -fno-warn-unused-imports -rtsopts -with-rtsopts "-M2G" + -threaded + -- ^ threaded is not necessary at all, but our CI trusts on being able + -- to pass -N1, which is not possible without threaded :-/ + -- (plus -no-threaded is not a thing, afaict) } test-suite littests @@ -372,4 +376,8 @@ test-suite libinterfacetests -fno-warn-unused-imports -rtsopts -with-rtsopts "-M2G" + -threaded + -- ^ threaded is not necessary at all, but our CI trusts on being able + -- to pass -N1, which is not possible without threaded :-/ + -- (plus -no-threaded is not a thing, afaict) } diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 1196a56..284c696 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -23,7 +23,6 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config import Data.Coerce ( coerce ) -import GHC.Conc ( getNumCapabilities ) import qualified Data.Text.IO as Text.IO import System.FilePath ( () ) @@ -50,8 +49,7 @@ main = do let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree - jobs <- getNumCapabilities - hspecWith (defaultConfig { configConcurrentJobs = Just jobs }) $ do + hspec $ do groups `forM_` \(groupname, tests) -> do describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do (if pend then before_ pending else id) -- 2.30.2 From 9de3564e0017a04bed74fd1e1dd7f53cf8e4ab00 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 14 Oct 2018 00:56:35 +0200 Subject: [PATCH 218/478] travis: Apply fix to stack and new-build too --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index d148072..58a4ab2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -271,7 +271,7 @@ script: set -ex case "$BUILD" in stack) - better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror" + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts -N1" ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi @@ -292,7 +292,7 @@ script: canew) better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks - time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" + time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS -with-rtsopts -N1" ;; esac set +ex -- 2.30.2 From d769f30c156a4cc4a573b8a9d093f0712cfa47be Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 14 Oct 2018 12:44:38 +0200 Subject: [PATCH 219/478] travis: Prevent duplicate compilation --- .travis.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 58a4ab2..fc67cae 100644 --- a/.travis.yml +++ b/.travis.yml @@ -257,8 +257,8 @@ install: cabal --version travis_retry cabal update -v echo 'packages: .' > cabal.project - echo 'package brittany' > cabal.project.local - echo ' ghc-options: -Werror' >> cabal.project.local + echo 'package brittany' > cabal.project.local + echo ' ghc-options: -Werror -with-rtsopts=-N1' >> cabal.project.local rm -f cabal.project.freeze cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep @@ -271,13 +271,13 @@ script: set -ex case "$BUILD" in stack) - better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts -N1" + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts=-N1" ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) - time cabal test --ghc-options="-with-rtsopts -N1" + time cabal test --ghc-options="-with-rtsopts=-N1" ;; cabaldist) # cabal check @@ -292,7 +292,7 @@ script: canew) better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks - time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS -with-rtsopts -N1" + time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" ;; esac set +ex -- 2.30.2 From e1b43531a869468960fd6535a1a35e7ad3de088d Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Sat, 13 Oct 2018 14:31:16 -0400 Subject: [PATCH 220/478] Add type synonym formatting --- src-literatetests/10-tests.blt | 94 ++++++++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 105 +++++++++++++++++- .../Haskell/Brittany/Internal/Prelude.hs | 8 ++ 3 files changed, 206 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1597c4b..f2b02d8 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -906,6 +906,100 @@ import qualified Data.List as L -- Test import Test ( test ) + +############################################################################### +############################################################################### +############################################################################### +#group type synonyms +############################################################################### +############################################################################### +############################################################################### + +#test simple-synonym + +type MySynonym = String + +#test parameterised-synonym + +type MySynonym a = [a] + +#test long-function-synonym + +-- | Important comment thrown in +type MySynonym b a + = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b + +#test overflowing-function-synonym + +type MySynonym3 b a + = MySynonym a b + -> MySynonym a b + -- ^ RandomComment + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-kind-sig + +type MySynonym (a :: * -> *) + = MySynonym a b + -> MySynonym a b + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-constraint + +type MySynonym a = Num a => a -> Int + +#test synonym-overflowing-with-constraint + +type MySynonym a + = Num a + => AReallyLongTypeName + -> AnotherReallyLongTypeName + -> AThirdTypeNameToOverflow + +#test synonym-forall + +{-# LANGUAGE RankNTypes #-} + +type MySynonym = forall a . [a] + +#test synonym-operator + +type (:+:) a b = (a, b) + +#test synonym-infix + +type a `MySynonym` b = a -> b + +#test synonym-infix-operator + +type a :+: b = (a, b) + +#test synonym-infix-parens + +type (a `Foo` b) c = (a, b, c) + +#test synonym-comments +#pending + +type Foo a -- fancy type comment + = -- strange comment + Int + +#test synonym-type-operators +#pending + +type (a :+: b) = (a, b) + +#test synonym-multi-parens +#pending + +type ((a :+: b) c) = (a, c) + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 2ece967..49fbd12 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -26,7 +26,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc, GenLocated(L), moduleNameString ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId (..) + ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name @@ -34,6 +38,9 @@ import BasicTypes ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) +#if MIN_VERSION_ghc(8,2,0) + , LexicalFixity(..) +#endif ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) @@ -43,6 +50,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Bag ( mapBagM, bagToList, emptyBag ) +import Data.Char (isUpper) @@ -52,6 +60,7 @@ layoutDecl d@(L loc decl) = case decl of ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n + TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD{}) -> do -- this is a (temporary (..)) workaround for "type instance" decls -- that do not round-trip through exactprint properly. @@ -69,6 +78,10 @@ layoutDecl d@(L loc decl) = case decl of _ -> briDocByExactNoComment d +-------------------------------------------------------------------------------- +-- Sig +-------------------------------------------------------------------------------- + layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ @@ -168,6 +181,11 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of ] _ -> unknownNodeError "" lgstmt -- TODO + +-------------------------------------------------------------------------------- +-- HsBind +-------------------------------------------------------------------------------- + layoutBind :: ToBriDocC (HsBindLR GhcPs GhcPs) @@ -595,6 +613,91 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine + +-------------------------------------------------------------------------------- +-- TyClDecl +-------------------------------------------------------------------------------- + +layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl ltycl@(L _loc tycl) = case tycl of +#if MIN_VERSION_ghc(8,2,0) + SynDecl name vars fixity typ _ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True +#else + SynDecl name vars typ _ -> do + nameStr <- lrdrNameToTextAnn name + let isInfixTypeOp = case Text.uncons nameStr of + Nothing -> False + Just (c, _) -> not (c == '(' || isUpper c) + isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote +#endif + docWrapNode ltycl $ layoutSynDecl isInfix name (hsq_explicit vars) typ + _ -> briDocByExactNoComment ltycl + +layoutSynDecl + :: Bool + -> Located (IdP GhcPs) + -> [LHsTyVarBndr GhcPs] + -> LHsType GhcPs + -> ToBriDocM BriDocNumbered +layoutSynDecl isInfix name vars typ = do + nameStr <- lrdrNameToTextAnn name + let + lhs = if isInfix + then do + let + (a : b : rest) = vars + -- This isn't quite right, but does give syntactically valid results + hasParens = not $ null rest + docSeq + $ [ appSep $ docLit $ Text.pack "type" + , appSep + . docSeq + $ [ docParenL | hasParens ] + ++ [ appSep $ layoutTyVarBndr a + , appSep $ docLit nameStr + , layoutTyVarBndr b + ] + ++ [ docParenR | hasParens ] + ] + ++ fmap (appSep . layoutTyVarBndr) rest + else + docSeq + $ [appSep $ docLit $ Text.pack "type", appSep $ docLit nameStr] + ++ fmap (appSep . layoutTyVarBndr) vars + typeDoc <- docSharedWrapper layoutType typ + docAlt + [ docSeq [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + , docAddBaseY BrIndentRegular $ docPar + lhs + (docCols + ColTyOpPrefix + [docLit $ Text.pack "= ", docAddBaseY (BrIndentSpecial 2) typeDoc] + ) + ] + +layoutTyVarBndr :: ToBriDoc HsTyVarBndr +layoutTyVarBndr (L _ bndr) = case bndr of + UserTyVar name -> do + nameStr <- lrdrNameToTextAnn name + docLit nameStr + KindedTyVar name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] + + +-------------------------------------------------------------------------------- +-- ClsInstDecl +-------------------------------------------------------------------------------- + -- | Layout an @instance@ declaration -- -- Layout signatures and bindings using the corresponding layouters from the diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 2d8a038..6b93bf0 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,3 +1,8 @@ +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +{-# LANGUAGE TypeFamilies #-} +#endif + + module Language.Haskell.Brittany.Internal.Prelude ( module E , module Language.Haskell.Brittany.Internal.Prelude @@ -400,5 +405,8 @@ todo = error "todo" #if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +type family IdP p +type instance IdP GhcPs = RdrName + type GhcPs = RdrName #endif -- 2.30.2 From b249c10054d4c958d20c682028e10c86e274c3ca Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Wed, 17 Oct 2018 17:01:31 -0400 Subject: [PATCH 221/478] Deal with parens inside comments on 8.4.3 --- .../Haskell/Brittany/Internal/Backend.hs | 5 ++ .../Haskell/Brittany/Internal/BackendUtils.hs | 12 +++++ .../Brittany/Internal/LayouterBasics.hs | 10 ++++ .../Brittany/Internal/Layouters/Decl.hs | 48 +++++++++++-------- 4 files changed, 56 insertions(+), 19 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 16a9362..6652443 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -19,6 +19,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) +import GHC ( AnnKeywordId (..) ) + import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.BackendUtils import Language.Haskell.Brittany.Internal.Utils @@ -173,6 +175,8 @@ layoutBriDocM = \case -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + "(" -> pure () + ")" -> layoutMoveToCommentPosX (x - 1) _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -244,6 +248,7 @@ layoutBriDocM = \case -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + ")" -> layoutMoveToCommentPosX (x - 1) _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index a7d8594..56b95bb 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -26,6 +26,7 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutAddSepSpace , layoutSetCommentCol , layoutMoveToCommentPos + , layoutMoveToCommentPosX , layoutIndentRestorePostComment , moveToExactAnn , ppmMoveToExactLoc @@ -200,6 +201,17 @@ layoutMoveToCommentPos y x = do Right{} -> lstate_baseY state } +layoutMoveToCommentPosX + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () +layoutMoveToCommentPosX x = do + traceLocal ("layoutMoveToCommentPosX", x) + state <- mGet + mSet state { _lstate_addSepSpace = Just $ _lstate_indLevelLinger state + x } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index bfb129a..9f6366e 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -63,6 +63,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSharedWrapper , hasAnyCommentsBelow , hasAnyCommentsConnected + , hasAnnKeywordComment , hasAnnKeyword ) where @@ -296,6 +297,15 @@ hasAnyCommentsConnected ast = do $ Map.elems $ anns +hasAnnKeywordComment + :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = do + anns <- mAsk + pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> False + Just ann -> any hasK (extractAllComments ann) + where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + hasAnnKeyword :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) => Located a diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 49fbd12..4576e48 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -633,34 +633,41 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of Just (c, _) -> not (c == '(' || isUpper c) isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote #endif - docWrapNode ltycl $ layoutSynDecl isInfix name (hsq_explicit vars) typ + hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + let parenWrapper = if hasTrailingParen + then appSep . docWrapNodeRest ltycl + else id + docWrapNodePrior ltycl + $ layoutSynDecl isInfix parenWrapper name (hsq_explicit vars) typ _ -> briDocByExactNoComment ltycl layoutSynDecl :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> Located (IdP GhcPs) -> [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix name vars typ = do +layoutSynDecl isInfix parenWrapper name vars typ = do nameStr <- lrdrNameToTextAnn name let lhs = if isInfix then do let (a : b : rest) = vars + hasOwnParens <- hasAnnKeywordComment a AnnOpenP -- This isn't quite right, but does give syntactically valid results - hasParens = not $ null rest - docSeq + let needsParens = not $ null rest || hasOwnParens + parenWrapper . docSeq $ [ appSep $ docLit $ Text.pack "type" , appSep . docSeq - $ [ docParenL | hasParens ] + $ [ docParenL | needsParens ] ++ [ appSep $ layoutTyVarBndr a , appSep $ docLit nameStr , layoutTyVarBndr b ] - ++ [ docParenR | hasParens ] + ++ [ docParenR | needsParens ] ] ++ fmap (appSep . layoutTyVarBndr) rest else @@ -679,19 +686,22 @@ layoutSynDecl isInfix name vars typ = do ] layoutTyVarBndr :: ToBriDoc HsTyVarBndr -layoutTyVarBndr (L _ bndr) = case bndr of - UserTyVar name -> do - nameStr <- lrdrNameToTextAnn name - docLit nameStr - KindedTyVar name kind -> do - nameStr <- lrdrNameToTextAnn name - docSeq - [ docLit $ Text.pack "(" - , appSep $ docLit nameStr - , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind - , docLit $ Text.pack ")" - ] +layoutTyVarBndr lbndr@(L _ bndr) = do + needsPriorSpace <- hasAnnKeywordComment lbndr AnnCloseP + docWrapNodePrior lbndr $ case bndr of + UserTyVar name -> do + nameStr <- lrdrNameToTextAnn name + docSeq $ [ docSeparator | needsPriorSpace ] ++ [docLit nameStr] + KindedTyVar name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsPriorSpace ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] -------------------------------------------------------------------------------- -- 2.30.2 From e7d8b5f1abdd3539c1b2f6bae1f01bfa33f4230d Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Fri, 19 Oct 2018 15:32:37 -0400 Subject: [PATCH 222/478] Fix type synonym comments --- src-literatetests/10-tests.blt | 1 - .../Brittany/Internal/LayouterBasics.hs | 33 +++++++++----- .../Brittany/Internal/Layouters/Decl.hs | 45 ++++++++++--------- 3 files changed, 45 insertions(+), 34 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index f2b02d8..83dfc61 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -983,7 +983,6 @@ type a :+: b = (a, b) type (a `Foo` b) c = (a, b, c) #test synonym-comments -#pending type Foo a -- fancy type comment = -- strange comment diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 9f6366e..458f7ed 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -63,6 +63,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSharedWrapper , hasAnyCommentsBelow , hasAnyCommentsConnected + , hasAnyCommentsPrior , hasAnnKeywordComment , hasAnnKeyword ) @@ -297,13 +298,16 @@ hasAnyCommentsConnected ast = do $ Map.elems $ anns +hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsPrior ast = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -hasAnnKeywordComment ast annKeyword = do - anns <- mAsk - pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> False - Just ann -> any hasK (extractAllComments ann) +hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just ann -> any hasK (extractAllComments ann) where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst hasAnnKeyword @@ -311,13 +315,18 @@ hasAnnKeyword => Located a -> AnnKeywordId -> m Bool -hasAnnKeyword ast annKeyword = do - anns <- mAsk - let hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks +hasAnnKeyword ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + where + hasK (ExactPrint.Types.G x, _) = x == annKeyword + hasK _ = False + +astAnn + :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) + => GHC.Located ast + -> m (Maybe Annotation) +astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk -- new BriDoc stuff diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 4576e48..7f37282 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -633,12 +633,13 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of Just (c, _) -> not (c == '(' || isUpper c) isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote #endif - hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP - let parenWrapper = if hasTrailingParen - then appSep . docWrapNodeRest ltycl - else id + -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + -- let parenWrapper = if hasTrailingParen + -- then appSep . docWrapNodeRest ltycl + -- else id + let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl - $ layoutSynDecl isInfix parenWrapper name (hsq_explicit vars) typ + $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ _ -> briDocByExactNoComment ltycl layoutSynDecl @@ -648,17 +649,16 @@ layoutSynDecl -> [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix parenWrapper name vars typ = do +layoutSynDecl isInfix wrapNodeRest name vars typ = do nameStr <- lrdrNameToTextAnn name let - lhs = if isInfix + lhs = appSep . wrapNodeRest $ if isInfix then do - let - (a : b : rest) = vars + let (a : b : rest) = vars hasOwnParens <- hasAnnKeywordComment a AnnOpenP - -- This isn't quite right, but does give syntactically valid results + -- This isn't quite right, but does give syntactically valid results let needsParens = not $ null rest || hasOwnParens - parenWrapper . docSeq + docSeq $ [ appSep $ docLit $ Text.pack "type" , appSep . docSeq @@ -672,18 +672,21 @@ layoutSynDecl isInfix parenWrapper name vars typ = do ++ fmap (appSep . layoutTyVarBndr) rest else docSeq - $ [appSep $ docLit $ Text.pack "type", appSep $ docLit nameStr] + $ [ appSep $ docLit $ Text.pack "type" + , appSep $ docWrapNode name $ docLit nameStr + ] ++ fmap (appSep . layoutTyVarBndr) vars - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsConnected typ docAlt - [ docSeq [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] - , docAddBaseY BrIndentRegular $ docPar - lhs - (docCols - ColTyOpPrefix - [docLit $ Text.pack "= ", docAddBaseY (BrIndentSpecial 2) typeDoc] - ) - ] + $ [ docSeq + [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + | not hasComments + ] + ++ [ docAddBaseY BrIndentRegular $ docPar + lhs + (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) + ] layoutTyVarBndr :: ToBriDoc HsTyVarBndr layoutTyVarBndr lbndr@(L _ bndr) = do -- 2.30.2 From ad5868eb76cc8865750e19d31980104667d630ee Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 27 Oct 2018 16:04:57 +0200 Subject: [PATCH 223/478] Fix spacing bugs, Clean up implemenation - Normalize spaces on type alias lhs. unnecessary spaces were retained previously, e.g. "type ( ( a :%: b ) c ) = (a , c)" had non-optimal output - Clean up separator usage - Remove backend hacks (to some degree) - Minor reformatting and premature optimization --- .../Haskell/Brittany/Internal/Backend.hs | 12 +++-- .../Haskell/Brittany/Internal/BackendUtils.hs | 35 +++++------- .../Brittany/Internal/Layouters/Decl.hs | 53 +++++++++---------- 3 files changed, 46 insertions(+), 54 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 6652443..1061f0e 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -172,11 +172,13 @@ layoutBriDocM = \case priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + -- ^ evil hack for CPP "(" -> pure () - ")" -> layoutMoveToCommentPosX (x - 1) + ")" -> pure () + -- ^ these two fix the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -245,10 +247,12 @@ layoutBriDocM = \case Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) - ")" -> layoutMoveToCommentPosX (x - 1) + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 56b95bb..0a2792c 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -26,7 +26,6 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutAddSepSpace , layoutSetCommentCol , layoutMoveToCommentPos - , layoutMoveToCommentPosX , layoutIndentRestorePostComment , moveToExactAnn , ppmMoveToExactLoc @@ -189,30 +188,20 @@ layoutMoveToCommentPos y x = do { _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 + , _lstate_addSepSpace = + Just $ if Data.Maybe.isJust (_lstate_commentCol state) + then case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else if y == 0 then x else _lstate_indLevelLinger state + x + , _lstate_commentCol = + Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state } -layoutMoveToCommentPosX - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => Int - -> m () -layoutMoveToCommentPosX x = do - traceLocal ("layoutMoveToCommentPosX", x) - state <- mGet - mSet state { _lstate_addSepSpace = Just $ _lstate_indLevelLinger state + x } - -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline :: ( MonadMultiWriter Text.Builder.Builder m diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 7f37282..cf7da4f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -659,46 +659,45 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do -- This isn't quite right, but does give syntactically valid results let needsParens = not $ null rest || hasOwnParens docSeq - $ [ appSep $ docLit $ Text.pack "type" - , appSep - . docSeq - $ [ docParenL | needsParens ] - ++ [ appSep $ layoutTyVarBndr a - , appSep $ docLit nameStr - , layoutTyVarBndr b - ] - ++ [ docParenR | needsParens ] + $ [ docLit $ Text.pack "type" + , docSeparator ] - ++ fmap (appSep . layoutTyVarBndr) rest + ++ [ docParenL | needsParens ] + ++ [ layoutTyVarBndr False a + , docSeparator + , docLit nameStr + , docSeparator + , layoutTyVarBndr False b + ] + ++ [ docParenR | needsParens ] + ++ fmap (layoutTyVarBndr True) rest else docSeq - $ [ appSep $ docLit $ Text.pack "type" - , appSep $ docWrapNode name $ docLit nameStr + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr ] - ++ fmap (appSep . layoutTyVarBndr) vars + ++ fmap (layoutTyVarBndr True) vars + sharedLhs <- docSharedWrapper id lhs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ - docAlt - $ [ docSeq - [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] - | not hasComments - ] - ++ [ docAddBaseY BrIndentRegular $ docPar - lhs - (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) - ] + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [sharedLhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + addAlternative $ docAddBaseY BrIndentRegular $ docPar + sharedLhs + (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) -layoutTyVarBndr :: ToBriDoc HsTyVarBndr -layoutTyVarBndr lbndr@(L _ bndr) = do - needsPriorSpace <- hasAnnKeywordComment lbndr AnnCloseP +layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr +layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar name -> do nameStr <- lrdrNameToTextAnn name - docSeq $ [ docSeparator | needsPriorSpace ] ++ [docLit nameStr] + docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] KindedTyVar name kind -> do nameStr <- lrdrNameToTextAnn name docSeq - $ [ docSeparator | needsPriorSpace ] + $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" -- 2.30.2 From 522e40c8ed77646d554d50a3648ee2da3768d7f8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 18 Sep 2018 18:05:03 +0200 Subject: [PATCH 224/478] Retain empty lines before "where" only applies to local "where"s (not module..where) --- .../Haskell/Brittany/Internal/Backend.hs | 17 ++++-- .../Brittany/Internal/LayouterBasics.hs | 9 ++- .../Brittany/Internal/Layouters/Decl.hs | 61 +++++++++++-------- .../Brittany/Internal/Layouters/Expr.hs | 6 +- .../Brittany/Internal/Layouters/Module.hs | 2 +- .../Brittany/Internal/Transformations/Alt.hs | 8 +-- .../Haskell/Brittany/Internal/Types.hs | 58 +++++++++--------- 7 files changed, 90 insertions(+), 71 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 1061f0e..d5a2434 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -235,7 +235,10 @@ layoutBriDocM = \case { _lstate_comments = Map.adjust ( \ann -> ann { ExactPrint.annFollowingComments = [] , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = [] + , ExactPrint.annsDP = + flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True } ) annKey @@ -259,7 +262,7 @@ layoutBriDocM = \case -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDMoveToKWDP annKey keyword bd -> do + BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet let m = _lstate_comments state @@ -269,12 +272,14 @@ layoutBriDocM = \case , (ExactPrint.Types.G kw1, dp) <- ann , keyword == kw1 ] + -- mTell $ Seq.fromList ["KWDP: " ++ show annKey ++ " " ++ show mAnn] pure $ case relevant of [] -> Nothing (dp:_) -> Just dp case mDP of - Nothing -> pure () - Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y x + Nothing -> pure () + Just (ExactPrint.Types.DP (y, x)) -> + layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd @@ -308,7 +313,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd BDLines ls@(_:_) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x @@ -344,7 +349,7 @@ briDocIsMultiLine briDoc = rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd BDLines (_:_:_) -> True BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 458f7ed..6352662 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -527,9 +527,11 @@ docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docMoveToKWDP :: AnnKey -> AnnKeywordId + -> Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docMoveToKWDP annKey kw bdm = allocateNode . BDFMoveToKWDP annKey kw =<< bdm +docMoveToKWDP annKey kw shouldRestoreIndent bdm = + allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm docAnnotationRest :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -597,10 +599,11 @@ docNodeMoveToKWDP :: Data.Data.Data ast => Located ast -> AnnKeywordId + -> Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNodeMoveToKWDP ast kw bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw bdm +docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index cf7da4f..2616312 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -26,11 +26,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId (..) - ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name @@ -204,13 +204,14 @@ layoutBind lbind@(L _ bind) = case bind of patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lbind, d) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs - mWhereDocs + mWhereArg hasComments _ -> Right <$> unknownNodeError "" lbind @@ -282,13 +283,14 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do $ (List.intersperse docSeparator $ docForceSingleline <$> ps) clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) let alignmentToken = if null pats then Nothing else mIdStr hasComments <- hasAnyCommentsBelow lmatch layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs - mWhereDocs + mWhereArg hasComments #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 && ghc-8.4 */ @@ -319,7 +321,8 @@ layoutPatternBindFinal -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe [BriDocNumbered] + -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) + -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do @@ -345,30 +348,36 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha -- be shared between alternatives. wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of Nothing -> return $ [] - Just [w] -> fmap (pure . pure) $ docAlt + Just (annKeyWhere, [w]) -> fmap (pure . pure) $ docAlt [ docEnsureIndent BrIndentRegular $ docSeq [ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] - , docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ return w - ] - ] - Just ws -> fmap (pure . pure) $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws + , docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ return w + ] ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] let singleLineGuardsDoc guards = appSep $ case guards of [] -> docEmpty [g] -> docSeq @@ -380,7 +389,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ) wherePart = case mWhereDocs of Nothing -> Just docEmpty - Just [w] -> Just $ docSeq + Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 1da80ae..3ade42e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -111,7 +111,8 @@ layoutExpr lexpr@(L _ expr) = do HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do #endif binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) @@ -410,7 +411,8 @@ layoutExpr lexpr@(L _ expr) = do HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docAlt [ docSetParSpacing $ docAddBaseY BrIndentRegular diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 2eebd20..cb82c75 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -40,7 +40,7 @@ layoutModule lmod@(L _ mod') = case mod' of [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ runFilteredAlternative $ do + , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 218f596..b73fc77 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -296,8 +296,8 @@ transformAlts = reWrap . BDFAnnotationRest annKey <$> rec bd BDFAnnotationKW annKey kw bd -> reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw bd -> - reWrap . BDFMoveToKWDP annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines (l:lr) -> do ind <- _acp_indent <$> mGet @@ -457,7 +457,7 @@ getSpacing !bridoc = rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False @@ -730,7 +730,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_:_) -> do -- we simply assume that lines is only used "properly", i.e. in diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 9358c2b..e54d35e 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -246,7 +246,7 @@ data BriDoc | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -292,7 +292,7 @@ data BriDocF f | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) - | BDFMoveToKWDP AnnKey AnnKeywordId (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) @@ -326,7 +326,7 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw bd) = plate BDMoveToKWDP |- annKey |- kw |* bd + uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd @@ -358,7 +358,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFMoveToKWDP annKey kw bd -> BDMoveToKWDP annKey kw $ rec bd + BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd @@ -377,32 +377,32 @@ isNotEmpty _ = True -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDMoveToKWDP _annKey _kw bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd + BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd -- 2.30.2 From 2eb22e730f7075a6fa761b0ad7cfd8557da80584 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 10 Oct 2018 21:26:55 +0200 Subject: [PATCH 225/478] Add tests for empty lines around where --- src-literatetests/10-tests.blt | 35 ++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 83dfc61..15a021e 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1106,3 +1106,38 @@ instance MyClass Int where -- ^ Interesting field , intData2 :: Int } + + +############################################################################### +############################################################################### +############################################################################### +#group whitespace-newlines +############################################################################### +############################################################################### +############################################################################### + +#test module-import-newlines + +module Main where + +import Prelude + +firstDecl = True + +#test function-where-newlines + +func = do + + -- complex first step + aaa + + -- complex second step + bbb + + where + + helper :: Helper + helper = helpful + + other :: Other + other = True -- 2.30.2 From 34735e27ef7c9a8ee929034e8256eaf9c9c2b271 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Jul 2018 19:55:49 +0200 Subject: [PATCH 226/478] Add compat with GHC-8.6 API --- brittany.cabal | 8 +- src/Language/Haskell/Brittany/Internal.hs | 18 + .../Brittany/Internal/ExactPrintUtils.hs | 26 +- .../Brittany/Internal/Layouters/Decl.hs | 128 ++++- .../Brittany/Internal/Layouters/Expr.hs | 440 ++++++++++++------ .../Haskell/Brittany/Internal/Layouters/IE.hs | 26 +- .../Brittany/Internal/Layouters/Import.hs | 4 + .../Brittany/Internal/Layouters/Pattern.hs | 68 ++- .../Brittany/Internal/Layouters/Stmt.hs | 20 + .../Brittany/Internal/Layouters/Type.hs | 119 ++++- .../Brittany/Internal/Transformations/Alt.hs | 4 +- 11 files changed, 678 insertions(+), 183 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index da69f91..9f04fff 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -83,12 +83,12 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.9 && <4.12 - , ghc >=8.0.1 && <8.5 + { base >=4.9 && <4.13 + , ghc >=8.0.1 && <8.7 , ghc-paths >=0.1.0.9 && <0.2 , ghc-exactprint >=0.5.8 && <0.5.9 , transformers >=0.5.2.0 && <0.6 - , containers >=0.5.7.1 && <0.6 + , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 , text >=1.2 && <1.3 , multistate >=0.7.1.1 && <0.9 @@ -111,7 +111,7 @@ library { , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.0.1 && <8.5 + , ghc-boot-th >=8.0.1 && <8.7 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 5b6e7ef..9720106 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -487,10 +487,17 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do getDeclBindingNames :: LHsDecl GhcPs -> [String] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +getDeclBindingNames (L _ decl) = case decl of + SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) + ValD _ (FunBind _ (L _ n) _ _ _) -> [Text.unpack $ rdrNameToText n] + _ -> [] +#else getDeclBindingNames (L _ decl) = case decl of SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n] _ -> [] +#endif -- Prints the information associated with the module annotation @@ -564,15 +571,26 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do _sigHead :: Sig GhcPs -> String _sigHead = \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + TypeSig _ names _ -> +#else TypeSig names _ -> +#endif "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) _ -> "unknown sig" _bindHead :: HsBind GhcPs -> String +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +_bindHead = \case + FunBind _ fId _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) + PatBind _ _pat _ ([], []) -> "PatBind smth" + _ -> "unknown bind" +#else _bindHead = \case FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _pat _ _ _ ([], []) -> "PatBind smth" _ -> "unknown bind" +#endif diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 7c582f1..0c4f901 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -197,9 +197,17 @@ commentAnnFixTransform modul = SYB.everything (>>) genF modul genF = (\_ -> return ()) `SYB.extQ` exprF exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () exprF lexpr@(L _ expr) = case expr of - RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) -> +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +#else + RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> +#endif moveTrailingComments lexpr (List.last fs) - RecordUpd _lname fs@(_:_) _ _ _ _ -> +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordUpd _ _e fs@(_:_) -> +#else + RecordUpd _e fs@(_:_) _cons _ _ _ -> +#endif moveTrailingComments lexpr (List.last fs) _ -> return () @@ -280,13 +288,13 @@ withTransformedAnns => ast -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -withTransformedAnns ast m = do - -- TODO: implement `local` for MultiReader/MultiRWS - readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - x <- m - MultiRWSS.mPutRawR readers - pure x +withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case + readers@(conf :+: anns :+: HNil) -> do + -- TODO: implement `local` for MultiReader/MultiRWS + MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) + x <- m + MultiRWSS.mPutRawR readers + pure x where f anns = let ((), (annsBalanced, _), _) = diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 2616312..37724f6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -55,28 +55,43 @@ import Data.Char (isUpper) layoutDecl :: ToBriDoc HsDecl +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +layoutDecl d@(L loc decl) = case decl of + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + InstD _ (TyFamInstD{}) -> layoutTyFamInstDWorkaround d + InstD _ (ClsInstD _ inst) -> + withTransformedAnns d $ layoutClsInst (L loc inst) + _ -> briDocByExactNoComment d +#else layoutDecl d@(L loc decl) = case decl of SigD sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD (TyFamInstD{}) -> do - -- this is a (temporary (..)) workaround for "type instance" decls - -- that do not round-trip through exactprint properly. - let fixer s = case List.stripPrefix "type " s of - Just rest | not ("instance" `isPrefixOf` rest) -> - "type instance " ++ rest - _ -> s - str <- mAsk <&> \anns -> - intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns - allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) - (foldedAnnKeys d) - False - (Text.pack str) + InstD (TyFamInstD{}) -> layoutTyFamInstDWorkaround d InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) - _ -> briDocByExactNoComment d + _ -> briDocByExactNoComment d +#endif +layoutTyFamInstDWorkaround :: ToBriDoc HsDecl +layoutTyFamInstDWorkaround d = do + -- this is a (temporary (..)) workaround for "type instance" decls + -- that do not round-trip through exactprint properly. + let fixer s = case List.stripPrefix "type " s of + Just rest | not ("instance" `isPrefixOf` rest) -> + "type instance " ++ rest + _ -> s + str <- mAsk <&> \anns -> + intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns + allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) + (foldedAnnKeys d) + False + (Text.pack str) -------------------------------------------------------------------------------- -- Sig @@ -84,12 +99,18 @@ layoutDecl d@(L loc decl) = case decl of layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ #else /* ghc-8.0 */ TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ #endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> +#else InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> +#endif docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig spec @@ -106,7 +127,9 @@ layoutSig lsig@(L _loc sig) = case sig of $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ #else /* ghc-8.0 */ ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ @@ -152,7 +175,6 @@ layoutSig lsig@(L _loc sig) = case sig of ) ] - specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String #if MIN_VERSION_ghc(8,4,0) @@ -171,8 +193,16 @@ specStringCompat _ = \case layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BodyStmt _ body _ _ -> layoutExpr body +#else BodyStmt body _ _ _ -> layoutExpr body +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BindStmt _ lPat expr _ _ -> do +#else BindStmt lPat expr _ _ _ -> do +#endif patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docCols ColBindStmt @@ -191,7 +221,11 @@ layoutBind (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do +#else FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do +#endif idStr <- lrdrNameToTextAnn fId binderDoc <- docLit $ Text.pack "=" funcPatDocs <- @@ -200,7 +234,11 @@ layoutBind lbind@(L _ bind) = case bind of $ layoutPatternBind (Just idStr) binderDoc `mapM` matches return $ Left $ funcPatDocs +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do +#else PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do +#endif patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds @@ -229,7 +267,11 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsValBinds _ (ValBinds _ bindlrs sigs) -> do +#else HsValBinds (ValBindsIn bindlrs sigs) -> do +#endif let unordered = [ BagBind b | b <- Data.Foldable.toList bindlrs ] ++ [ BagSig s | s <- sigs ] @@ -238,23 +280,36 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s return $ Just $ docs +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> + HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" + XHsLocalBindsLR{} -> error "brittany internal error: XHsLocalBindsLR" +#else x@(HsValBinds (ValBindsOut _binds _lsigs)) -> -- i _think_ this case never occurs in non-processed ast Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}" (L noSrcSpan x) - x@(HsIPBinds _ipBinds) -> +#endif + x@(HsIPBinds{}) -> Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x) - EmptyLocalBinds -> return $ Nothing + EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- parSpacing stuff.B layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do +#else layoutGrhs lgrhs@(L _ (GRHS guards body)) = do +#endif guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +layoutGrhs (L _ (XGRHS{})) = error "brittany internal error: XGRHS" +#endif layoutPatternBind :: Maybe Text @@ -263,7 +318,11 @@ layoutPatternBind -> ToBriDocM BriDocNumbered layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do let pats = m_pats match +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let (GRHSs _ grhss whereBinds) = m_grhss match +#else let (GRHSs grhss whereBinds) = m_grhss match +#endif patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match let mIdStr' = fixPatternBindIdentifier match <$> mIdStr @@ -629,7 +688,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of -#if MIN_VERSION_ghc(8,2,0) +#if MIN_VERSION_ghc(8,6,0) + SynDecl _ name vars fixity typ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True +#elif MIN_VERSION_ghc(8,2,0) SynDecl name vars fixity typ _ -> do let isInfix = case fixity of Prefix -> False @@ -700,10 +764,19 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of +#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ + XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" + UserTyVar _ name -> do +#else /* 8.0 8.2 8.4 */ UserTyVar name -> do +#endif nameStr <- lrdrNameToTextAnn name docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] +#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ + KindedTyVar _ name kind -> do +#else /* 8.0 8.2 8.4 */ KindedTyVar name kind -> do +#endif nameStr <- lrdrNameToTextAnn name docSeq $ [ docSeparator | needsSep ] @@ -736,8 +809,21 @@ layoutClsInst lcid@(L _ cid) = docLines ] where layoutInstanceHead :: ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ layoutInstanceHead = - briDocByExactNoComment $ InstD . ClsInstD . removeChildren <$> lcid + briDocByExactNoComment + $ InstD NoExt + . ClsInstD NoExt + . removeChildren + <$> lcid +#else + layoutInstanceHead = + briDocByExactNoComment + $ InstD + . ClsInstD + . removeChildren + <$> lcid +#endif removeChildren :: ClsInstDecl p -> ClsInstDecl p removeChildren c = c diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3ade42e..cab2baa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -37,9 +37,17 @@ layoutExpr lexpr@(L _ expr) = do .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsVar _ vname -> do +#else HsVar vname -> do +#endif docLit =<< lrdrNameToTextAnn vname +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsUnboundVar _ var -> case var of +#else HsUnboundVar var -> case var of +#endif OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname TrueExprHole oname -> docLit $ Text.pack $ occNameString oname HsRecFld{} -> do @@ -51,15 +59,35 @@ layoutExpr lexpr@(L _ expr) = do HsIPVar{} -> do -- TODO briDocByExactInlineOnly "HsOverLabel{}" lexpr - HsOverLit (OverLit olit _ _ _) -> do - allocateNode $ overLitValBriDoc olit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsOverLit _ olit -> do +#else + HsOverLit olit -> do +#endif + allocateNode $ overLitValBriDoc $ ol_val olit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLit _ lit -> do +#else HsLit lit -> do +#endif allocateNode $ litBriDoc lit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) +#else HsLam (MG (L _ [lmatch@(L _ match)]) _ _ _) +#endif | pats <- m_pats match - , GRHSs [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds <- llocals - , L _ (GRHS [] body) <- lgrhs +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + , GRHSs _ [lgrhs] llocals <- m_grhss match +#else + , GRHSs [lgrhs] llocals <- m_grhss match +#endif + , L _ EmptyLocalBinds {} <- llocals +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + , L _ (GRHS _ [] body) <- lgrhs +#else + , L _ (GRHS [] body) <- lgrhs +#endif -> do patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body @@ -105,9 +133,13 @@ layoutExpr lexpr@(L _ expr) = do ] HsLam{} -> unknownNodeError "HsLam too complex" lexpr -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLamCase _ XMatchGroup{} -> + error "brittany internal error: HsLamCase XMatchGroup" + HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do #endif binderDoc <- docLit $ Text.pack "->" @@ -116,14 +148,26 @@ layoutExpr lexpr@(L _ expr) = do docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsApp _ exp1@(L _ HsApp{}) exp2 -> do +#else HsApp exp1@(L _ HsApp{}) exp2 -> do +#endif let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) gather list = \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (HsApp _ l r) -> gather (r:list) l +#else L _ (HsApp l r) -> gather (r:list) l +#endif x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 let colsOrSequence = case headE of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (HsVar _ (L _ (Unqual occname))) -> +#else L _ (HsVar (L _ (Unqual occname))) -> +#endif docCols (ColApp $ Text.pack $ occNameString occname) _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE @@ -168,7 +212,11 @@ layoutExpr lexpr@(L _ expr) = do ( docNonBottomSpacing $ docLines paramDocs ) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsApp _ exp1 exp2 -> do +#else HsApp exp1 exp2 -> do +#endif -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 @@ -206,9 +254,13 @@ layoutExpr lexpr@(L _ expr) = do expDoc1 expDoc2 ] -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsAppType XHsWildCardBndrs{} _ -> + error "brittany internal error: HsAppType XHsWildCardBndrs" + HsAppType (HsWC _ ty1) exp1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ HsAppType exp1 (HsWC _ ty1) -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ HsAppType exp1 (HsWC _ _ ty1) -> do #endif t <- docSharedWrapper layoutType ty1 @@ -224,13 +276,23 @@ layoutExpr lexpr@(L _ expr) = do e (docSeq [docLit $ Text.pack "@", t ]) ] +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ HsAppTypeOut{} -> do -- TODO briDocByExactInlineOnly "HsAppTypeOut{}" lexpr +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do +#else OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do +#endif let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) gather opExprList = \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 +#else (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 +#endif final -> (final, opExprList) (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand @@ -244,11 +306,19 @@ layoutExpr lexpr@(L _ expr) = do hasComLeft <- hasAnyCommentsConnected expLeft hasComOp <- hasAnyCommentsConnected expOp pure $ not hasComLeft && not hasComOp +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True +#else let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True +#endif runFilteredAlternative $ do -- > one + two + three -- or @@ -286,15 +356,27 @@ layoutExpr lexpr@(L _ expr) = do $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + OpApp _ expLeft expOp expRight -> do +#else OpApp expLeft expOp _ expRight -> do +#endif expDocLeft <- docSharedWrapper layoutExpr expLeft expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True +#else let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True +#endif runFilteredAlternative $ do -- one-line addAlternative @@ -334,12 +416,20 @@ layoutExpr lexpr@(L _ expr) = do $ docPar expDocLeft (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + NegApp _ op _ -> do +#else NegApp op _ -> do +#endif opDoc <- docSharedWrapper layoutExpr op docSeq [ docLit $ Text.pack "-" , opDoc ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsPar _ innerExp -> do +#else HsPar innerExp -> do +#endif innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt [ docSeq @@ -355,18 +445,37 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack ")" ] ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + SectionL _ left op -> do -- TODO: add to testsuite +#else SectionL left op -> do -- TODO: add to testsuite +#endif leftDoc <- docSharedWrapper layoutExpr left opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + SectionR _ op right -> do -- TODO: add to testsuite +#else SectionR op right -> do -- TODO: add to testsuite +#endif opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ExplicitTuple _ args boxity -> do +#else ExplicitTuple args boxity -> do +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e); + (L _ (Missing NoExt)) -> (arg, Nothing) + (L _ XTupArg{}) -> error "brittany internal error: XTupArg" +#else let argExprs = args <&> \arg -> case arg of (L _ (Present e)) -> (arg, Just e); (L _ (Missing PlaceHolder)) -> (arg, Nothing) +#endif argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM @@ -408,7 +517,13 @@ layoutExpr lexpr@(L _ expr) = do lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] end = closeLit in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsCase _ _ XMatchGroup{} -> + error "brittany internal error: HsCase XMatchGroup" + HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do +#else HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do +#endif cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" funcPatDocs <- docWrapNode lmatches @@ -432,7 +547,11 @@ layoutExpr lexpr@(L _ expr) = do (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIf _ _ ifExpr thenExpr elseExpr -> do +#else HsIf _ ifExpr thenExpr elseExpr -> do +#endif ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr @@ -552,7 +671,11 @@ layoutExpr lexpr@(L _ expr) = do docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsLet _ binds exp1 -> do +#else HsLet binds exp1 -> do +#endif expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) @@ -655,60 +778,65 @@ layoutExpr lexpr@(L _ expr) = do ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] - HsDo DoExpr (L _ stmts) _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - HsDo MDoExpr (L _ stmts) _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - HsDo x (L _ stmts) _ | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ docForceSingleline <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative $ - let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - HsDo{} -> do - -- TODO - unknownNodeError "HsDo{} no comp" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of +#else + HsDo stmtCtx (L _ stmts) _ -> case stmtCtx of +#endif + DoExpr -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + MDoExpr -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ docNodeAnnKW lexpr Nothing + $ appSep + $ docLit + $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq $ List.intersperse docCommaSep + $ docForceSingleline <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative $ + let + start = docCols ColListComp + [ docNodeAnnKW lexpr Nothing + $ appSep $ docLit $ Text.pack "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1:sM) = List.init stmtDocs + line1 = docCols ColListComp + [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + _ -> do + -- TODO + unknownNodeError "HsDo{} unknown stmtCtx" lexpr ExplicitList _ _ elems@(_:_) -> do elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr @@ -749,80 +877,101 @@ layoutExpr lexpr@(L _ expr) = do in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ExplicitList _ _ [] -> docLit $ Text.pack "[]" +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ ExplicitPArr{} -> do -- TODO briDocByExactInlineOnly "ExplicitPArr{}" lexpr - RecordCon lname _ _ (HsRecFields fields Nothing) -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- fields - `forM` \lfield@(L _ (HsRecField (L _ (FieldOcc lnameF _)) rFExpr pun)) -> do - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression indentPolicy lexpr nameDoc rFs - - RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do - -- TODO this should be consolidated into `recordExpression` - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - let line1 wrapper = - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper x - ] - Nothing -> docEmpty +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordCon _ lname fields -> +#else + RecordCon lname _ _ fields -> +#endif + case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- fs + `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just 0) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do + -- TODO this should be consolidated into `recordExpression` + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return (fieldl, lrdrNameToText lnameF, fExpDoc) + let ((fd1l, fd1n, fd1e):fdr) = fieldDocs + let line1 wrapper = + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior fd1l $ appSep $ docLit fd1n + , case fd1e of + Just x -> docSeq + [ appSep $ docLit $ Text.pack "=" + , docWrapNodeRest fd1l $ wrapper x + ] + Nothing -> docEmpty + ] + let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docWrapNode lfield $ docSeq + [ appSep $ docLit $ Text.pack "=" + , wrapper x + ] + Nothing -> docEmpty + ] + let lineDot = + [ docCommaSep + , docLit $ Text.pack ".." + ] + let lineN = + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free + [ docSeq + $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] + ++ line1 docForceSingleline + ++ join (lineR docForceSingleline) + ++ lineDot + ++ [docSeparator] + ++ lineN + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + ( docNonBottomSpacing + $ docLines + $ [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)] + ++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular)) + ++ [docSeq lineDot, docSeq lineN] + ) ] - let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , wrapper x - ] - Nothing -> docEmpty - ] - let lineDot = - [ docCommaSep - , docLit $ Text.pack ".." - ] - let lineN = - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free - [ docSeq - $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] - ++ line1 docForceSingleline - ++ join (lineR docForceSingleline) - ++ lineDot - ++ [docSeparator] - ++ lineN - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - ( docNonBottomSpacing - $ docLines - $ [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)] - ++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular)) - ++ [docSeq lineDot, docSeq lineN] - ) - ] - RecordCon{} -> - unknownNodeError "RecordCon with puns" lexpr + _ -> unknownNodeError "RecordCon with puns" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecordUpd _ rExpr fields -> do +#else RecordUpd rExpr fields _ _ _ _ -> do +#endif rExprDoc <- docSharedWrapper layoutExpr rExpr rFs <- fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do @@ -830,10 +979,23 @@ layoutExpr lexpr@(L _ expr) = do then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ case ambName of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + XAmbiguousFieldOcc{} -> + error "brittany internal error: XAmbiguousFieldOcc" +#else Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) +#endif recordExpression indentPolicy lexpr rExprDoc rFs -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ -> + error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" + ExprWithTySig XHsWildCardBndrs{} _ -> + error "brittany internal error: ExprWithTySig XHsWildCardBndrs" + ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8,4 */ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #else /* ghc-8.0 */ ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do @@ -845,9 +1007,11 @@ layoutExpr lexpr@(L _ expr) = do , appSep $ docLit $ Text.pack "::" , typDoc ] +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ ExprWithTySigOut{} -> do -- TODO briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr +#endif ArithSeq _ Nothing info -> case info of From e1 -> do @@ -892,9 +1056,11 @@ layoutExpr lexpr@(L _ expr) = do ] ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ PArrSeq{} -> do -- TODO briDocByExactInlineOnly "PArrSeq{}" lexpr +#endif HsSCC{} -> do -- TODO briDocByExactInlineOnly "HsSCC{}" lexpr @@ -936,7 +1102,11 @@ layoutExpr lexpr@(L _ expr) = do briDocByExactInlineOnly "HsTickPragma{}" lexpr EWildPat{} -> do docLit $ Text.pack "_" +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + EAsPat _ asName asExpr -> do +#else EAsPat asName asExpr -> do +#endif docSeq [ docLit $ lrdrNameToText asName <> Text.pack "@" , layoutExpr asExpr @@ -958,6 +1128,9 @@ layoutExpr lexpr@(L _ expr) = do -- TODO briDocByExactInlineOnly "ExplicitSum{}" lexpr #endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + XExpr{} -> error "brittany internal error: XExpr" +#endif recordExpression :: (Data.Data.Data lExpr, Data.Data.Data name) @@ -1073,7 +1246,6 @@ recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = in [line1] ++ lineR ++ [lineN] ) - #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc = \case diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 42329cf..0407a3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -39,12 +39,32 @@ prepareName = id layoutIE :: ToBriDoc IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of - IEVar x -> layoutWrapped lie x +#if MIN_VERSION_ghc(8,6,0) + IEVar _ x -> layoutWrapped lie x +#else + IEVar x -> layoutWrapped lie x +#endif +#if MIN_VERSION_ghc(8,6,0) + IEThingAbs _ x -> layoutWrapped lie x +#else IEThingAbs x -> layoutWrapped lie x +#endif +#if MIN_VERSION_ghc(8,6,0) + IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] +#else IEThingAll x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] +#endif +#if MIN_VERSION_ghc(8,6,0) + IEThingWith _ x (IEWildcard _) _ _ -> +#else IEThingWith x (IEWildcard _) _ _ -> +#endif docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] +#if MIN_VERSION_ghc(8,6,0) + IEThingWith _ x _ ns _ -> do +#else IEThingWith x _ ns _ -> do +#endif hasComments <- hasAnyCommentsBelow lie runFilteredAlternative $ do addAlternativeCond (not hasComments) @@ -68,7 +88,11 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs ++ [docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN], docParenR] +#if MIN_VERSION_ghc(8,6,0) + IEModuleContents _ n -> docSeq +#else IEModuleContents n -> docSeq +#endif [ docLit $ Text.pack "module" , docSeparator , docLit . Text.pack . moduleNameString $ unLoc n diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index fc43ecf..bcce106 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -43,7 +43,11 @@ prepModName = id layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of +#if MIN_VERSION_ghc(8,6,0) + ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do +#else ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do +#endif importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index f409c30..e77856c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -13,7 +13,7 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString, ol_val ) import HsSyn import Name import BasicTypes @@ -37,11 +37,25 @@ layoutPat :: ToBriDocC (Pat GhcPs) (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr - VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + VarPat _ n -> +#else /* ghc-8.0 8.2 8.4 */ + VarPat n -> +#endif + fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LitPat _ lit -> +#else /* ghc-8.0 8.2 8.4 */ + LitPat lit -> +#endif + fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ParPat _ inner -> do +#else /* ghc-8.0 8.2 8.4 */ ParPat inner -> do +#endif -- (nestedpat) -> expr left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" @@ -89,7 +103,12 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat @@ -118,7 +137,12 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do -- Abc { a = locA, .. } let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + let FieldOcc _ lnameF = fieldOcc +#else + let FieldOcc lnameF _ = fieldOcc +#endif fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat @@ -136,18 +160,28 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of (fieldName, Nothing) -> [docLit fieldName, docCommaSep] , docLit $ Text.pack "..}" ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + TuplePat _ args boxity -> do +#else TuplePat args boxity _ -> do +#endif -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of Boxed -> wrapPatListy args "()" docParenL docParenR Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + AsPat _ asName asPat -> do +#else AsPat asName asPat -> do +#endif -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do #endif -- i :: Int -> expr @@ -169,19 +203,35 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docForceSingleline tyDoc ] return $ xR Seq.|> xN' +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + ListPat _ elems -> +#else ListPat elems _ _ -> +#endif -- [] -> expr1 -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 wrapPatListy elems "[]" docBracketL docBracketR +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BangPat _ pat1 -> do +#else BangPat pat1 -> do +#endif -- !nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "!") +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LazyPat _ pat1 -> do +#else LazyPat pat1 -> do +#endif -- ~nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "~") - NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + NPat _ llit@(L _ ol) mNegative _ -> do +#else + NPat llit@(L _ ol) mNegative _ _ -> do +#endif -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of Just{} -> Seq.fromList [negDoc, litDoc] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 7a9b922..3fd5f8a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -34,9 +34,17 @@ layoutStmt lstmt@(L _ stmt) = do indentAmount :: Int <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack docWrapNode lstmt $ case stmt of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LastStmt _ body False _ -> do +#else LastStmt body False _ -> do +#endif layoutExpr body +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BindStmt _ lPat expr _ _ -> do +#else BindStmt lPat expr _ _ _ -> do +#endif patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docAlt @@ -52,7 +60,11 @@ layoutStmt lstmt@(L _ stmt) = do $ docPar (docLit $ Text.pack "<-") (expDoc) ] ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + LetStmt _ binds -> do +#else LetStmt binds -> do +#endif let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case @@ -97,7 +109,11 @@ layoutStmt lstmt@(L _ stmt) = do $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do +#else RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do +#endif -- rec stmt1 -- stmt2 -- stmt3 @@ -113,7 +129,11 @@ layoutStmt lstmt@(L _ stmt) = do addAlternative $ docAddBaseY BrIndentRegular $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + BodyStmt _ expr _ _ -> do +#else BodyStmt expr _ _ _ -> do +#endif expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 5e97d5b..5bbbc4c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -23,6 +23,7 @@ import HsSyn import Name import Outputable ( ftext, showSDocUnsafe ) import BasicTypes +import qualified SrcLoc import DataTreePrint @@ -31,7 +32,17 @@ import DataTreePrint 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 */ +#if MIN_VERSION_ghc(8,6,0) + HsTyVar _ promoted name -> do + t <- lrdrNameToTextAnn name + case promoted of + Promoted -> docSeq + [ docSeparator + , docTick + , docWrapNode name $ docLit t + ] + NotPromoted -> docWrapNode name $ docLit t +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsTyVar promoted name -> do t <- lrdrNameToTextAnn name case promoted of @@ -46,13 +57,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of t <- lrdrNameToTextAnn name docWrapNode name $ docLit t #endif +#if MIN_VERSION_ghc(8,6,0) + HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do +#else HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do +#endif typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- bndrs `forM` \case +#if MIN_VERSION_ghc(8,6,0) + (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" +#else (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) (L _ (KindedTyVar lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) +#endif cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline @@ -143,13 +166,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsForAllTy _ bndrs typ2 -> do +#else HsForAllTy bndrs typ2 -> do +#endif typeDoc <- layoutType typ2 tyVarDocs <- bndrs `forM` \case +#if MIN_VERSION_ghc(8,6,0) + (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ lrdrName kind)) -> do + d <- layoutType kind + return $ (lrdrNameToText lrdrName, Just $ return d) + (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" +#else (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) (L _ (KindedTyVar lrdrName kind)) -> do d <- layoutType kind return $ (lrdrNameToText lrdrName, Just $ return d) +#endif let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline _ -> id @@ -210,7 +245,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do +#else HsQualTy lcntxts@(L _ cntxts) typ1 -> do +#endif typeDoc <- docSharedWrapper layoutType typ1 cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let @@ -260,7 +299,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsFunTy _ typ1 typ2 -> do +#else HsFunTy typ1 typ2 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 let maybeForceML = case typ2 of @@ -284,7 +327,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] +#if MIN_VERSION_ghc(8,6,0) + HsParTy _ typ1 -> do +#else HsParTy typ1 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -299,6 +346,35 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ]) (docLit $ Text.pack ")") ] +#if MIN_VERSION_ghc(8,6,0) + HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do + let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 + final -> (final, list) + let (typHead, typRest) = gather [typ2] typ1 + docHead <- docSharedWrapper layoutType typHead + docRest <- docSharedWrapper layoutType `mapM` typRest + docAlt + [ docSeq + $ docForceSingleline docHead : (docRest >>= \d -> + [ docSeparator, docForceSingleline d ]) + , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) + ] + HsAppTy _ typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + docAlt + [ docSeq + [ docForceSingleline typeDoc1 + , docSeparator + , docForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + (docEnsureIndent BrIndentRegular typeDoc2) + ] +#else HsAppTy typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 @@ -351,7 +427,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of layoutAppType (L _ (HsAppPrefix t)) = layoutType t layoutAppType lt@(L _ (HsAppInfix t)) = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t +#endif +#if MIN_VERSION_ghc(8,6,0) + HsListTy _ typ1 -> do +#else HsListTy typ1 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -366,6 +447,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ]) (docLit $ Text.pack "]") ] +#if MIN_VERSION_ghc(8,6,0) +#else HsPArrTy typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -381,13 +464,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ]) (docLit $ Text.pack ":]") ] +#endif +#if MIN_VERSION_ghc(8,6,0) + HsTupleTy _ tupleSort typs -> case tupleSort of +#else HsTupleTy tupleSort typs -> case tupleSort of +#endif HsUnboxedTuple -> unboxed HsBoxedTuple -> simple HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where - unboxed = if null typs then error "unboxed unit?" else unboxedL + unboxed = if null typs then error "brittany internal error: unboxed unit" + else unboxedL simple = if null typs then unitL else simpleL unitL = docLit $ Text.pack "()" simpleL = do @@ -480,9 +569,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- } -- , _layouter_ast = ltype -- } -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ HsIParamTy (L _ (HsIPName ipName)) typ1 -> do -#else /* ghc-8.0 */ +#else /* ghc-8.0 */ HsIParamTy (HsIPName ipName) typ1 -> do #endif typeDoc1 <- docSharedWrapper layoutType typ1 @@ -503,6 +594,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docAddBaseY (BrIndentSpecial 2) typeDoc1 ]) ] +#if MIN_VERSION_ghc(8,6,0) +#else HsEqTy typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 @@ -521,8 +614,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docAddBaseY (BrIndentSpecial 2) typeDoc2 ]) ] +#endif -- TODO: test KindSig +#if MIN_VERSION_ghc(8,6,0) + HsKindSig _ typ1 kind1 -> do +#else HsKindSig typ1 kind1 -> do +#endif typeDoc1 <- docSharedWrapper layoutType typ1 kindDoc1 <- docSharedWrapper layoutType kind1 hasParens <- hasAnnKeyword ltype AnnOpenP @@ -640,7 +738,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype +#if MIN_VERSION_ghc(8,6,0) + HsTyLit _ lit -> case lit of +#else HsTyLit lit -> case lit of +#endif #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsNumTy NoSourceText _ -> @@ -652,11 +754,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsNumTy srctext _ -> docLit $ Text.pack srctext HsStrTy srctext _ -> docLit $ Text.pack srctext #endif +#if !MIN_VERSION_ghc(8,6,0) HsCoreTy{} -> -- TODO briDocByExactInlineOnly "HsCoreTy{}" ltype +#endif HsWildCardTy _ -> docLit $ Text.pack "_" #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype #endif +#if MIN_VERSION_ghc(8,6,0) + HsStarTy _ isUnicode -> do + if isUnicode + then docLit $ Text.pack "\x2605" -- Unicode star + else docLit $ Text.pack "*" + XHsType{} -> error "brittany internal error: XHsType" +#endif diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index b73fc77..b9458fb 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -203,6 +203,7 @@ transformAlts = AltLineModeStateForceSL{} -> p == VerticalSpacingParNone AltLineModeStateForceML{} -> p /= VerticalSpacingParNone AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? lineCheck _ = error "ghc exhaustive check is insufficient" lconf <- _conf_layout <$> mAsk #if INSERTTRACESALT @@ -462,7 +463,8 @@ getSpacing !bridoc = rec bridoc $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False BDFLines ls@(_:_) -> do - lSps@(mVs:_) <- rec `mapM` ls + lSps <- rec `mapM` ls + let (mVs:_) = lSps -- separated into let to avoid MonadFail return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False | VerticalSpacing lsp _ _ <- mVs , lineMax <- getMaxVS $ maxVs $ lSps -- 2.30.2 From e7d8f59e93e3b1e7d469d1220580084c9eda86c9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 19 Aug 2018 15:10:24 +0200 Subject: [PATCH 227/478] travis-ci: Add ghc-8.6, Clean up a bit --- .travis.yml | 56 +------------------ .../Haskell/Brittany/Internal/Config.hs | 1 + 2 files changed, 4 insertions(+), 53 deletions(-) diff --git a/.travis.yml b/.travis.yml index fc67cae..ce2e49a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,26 +40,6 @@ before_cache: # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} matrix: include: - # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: - # https://github.com/hvr/multi-ghc-travis - #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.0.4" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.2.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.4.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.6.3" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.8.4" - # addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.10.3" - # addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} ##### OSX test via stack ##### @@ -79,6 +59,9 @@ matrix: - env: BUILD=cabal GHCVER=8.4.3 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.4.3" addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.6.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.6.1" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. @@ -106,18 +89,6 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-2" - # compiler: ": #stack 7.8.4" - # addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-3" - # compiler: ": #stack 7.10.2" - # addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-6" - # compiler: ": #stack 7.10.3" - # addons: {apt: {packages: [libgmp-dev]}} - #- env: BUILD=stack ARGS="--resolver lts-7" - # compiler: ": #stack 8.0.1" - # addons: {apt: {packages: [libgmp-dev]}} - env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml" compiler: ": #stack 8.0.2" addons: {apt: {packages: [libgmp-dev]}} @@ -130,27 +101,6 @@ matrix: compiler: ": #stack nightly" addons: {apt: {packages: [libgmp-dev]}} - # Travis includes an macOS which is incompatible with GHC 7.8.4 - #- env: BUILD=stack ARGS="--resolver lts-2" - # compiler: ": #stack 7.8.4 osx" - # os: osx - - #- env: BUILD=stack ARGS="--resolver lts-3" - # compiler: ": #stack 7.10.2 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver lts-6" - # compiler: ": #stack 7.10.3 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver lts-7" - # compiler: ": #stack 8.0.1 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver lts-8" - # compiler: ": #stack 8.0.2 osx" - # os: osx - #- env: BUILD=stack ARGS="--resolver nightly" - # compiler: ": #stack nightly osx" - # os: osx - allow_failures: #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=stack ARGS="--resolver nightly" diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 2e63b49..464bd3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -231,6 +231,7 @@ cmdlineConfigParser = do readConfig :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Option)) readConfig path = do + -- TODO: probably should catch IOErrors and then omit the existence check. exists <- liftIO $ System.Directory.doesFileExist path if exists then do -- 2.30.2 From 1290e8cd278778c2ba4dd21cb741649cab8a6e43 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Nov 2018 19:00:21 +0100 Subject: [PATCH 228/478] Bump CI ghc versions (8.4.3->8.4.4, 8.6.1->8.6.2) --- .travis.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index ce2e49a..195c1a2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -56,12 +56,12 @@ matrix: - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.2.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.4.3 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.4.3" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.6.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.6.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.4.4 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.4.4" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.6.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.6.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. -- 2.30.2 From 01e31b4256135d594ddc75cb36ef494d0a7ba875 Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Sun, 14 Oct 2018 14:28:43 -0400 Subject: [PATCH 229/478] Add type fam instance formatting --- src-literatetests/10-tests.blt | 41 ++++++ .../Brittany/Internal/LayouterBasics.hs | 54 +++++--- .../Brittany/Internal/Layouters/Decl.hs | 129 +++++++++++------- 3 files changed, 159 insertions(+), 65 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 15a021e..63e93c0 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1141,3 +1141,44 @@ func = do other :: Other other = True + + +############################################################################### +############################################################################### +############################################################################### +#group typefam.instance +############################################################################### +############################################################################### +############################################################################### + +#test simple-typefam-instance + +type instance MyFam Bool = String + +#test simple-typefam-instance-param-type + +type instance MyFam (Maybe a) = a -> Bool + +#test simple-typefam-instance-parens + +type instance (MyFam (String -> Int)) = String + +#test simple-typefam-instance-overflow + +type instance MyFam ALongishType + = AMuchLongerTypeThanThat + -> AnEvenLongerTypeThanTheLastOne + -> ShouldDefinitelyOverflow + +#test simple-typefam-instance-comments + +-- | A happy family +type instance MyFam Bool -- This is an odd one + = AnotherType -- Here's another + +#test simple-typefam-instance-parens-comment + +-- | A happy family +type instance (MyFam Bool) -- This is an odd one + = -- Here's another + AnotherType diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 6352662..977e8e8 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -9,6 +9,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments + , extractRestComments , filterAnns , docEmpty , docLit @@ -64,6 +65,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , hasAnyCommentsBelow , hasAnyCommentsConnected , hasAnyCommentsPrior + , hasAnyRegularCommentsConnected + , hasAnyRegularCommentsRest , hasAnnKeywordComment , hasAnnKeyword ) @@ -263,9 +266,13 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk extractAllComments :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] extractAllComments ann = - ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ++ ( ExactPrint.annsDP ann >>= \case + ExactPrint.annPriorComments ann ++ extractRestComments ann + +extractRestComments + :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +extractRestComments ann = + ExactPrint.annFollowingComments ann + ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] _ -> [] ) @@ -278,31 +285,40 @@ filterAnns ast = -- a) connected to any node below (in AST sense) the given node AND -- b) after (in source code order) the node. hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsBelow ast@(L l _) = do - anns <- filterAnns ast <$> mAsk - return - $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) - $ (=<<) extractAllComments - $ Map.elems - $ anns +hasAnyCommentsBelow ast@(L l _) = + List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) + <$> astConnectedComments ast --- | True if there are any comments that are --- connected to any node below (in AST sense) the given node +-- | True if there are any comments that are connected to any node below (in AST +-- sense) the given node hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsConnected ast = do +hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast + +-- | True if there are any regular comments connected to any node below (in AST +-- sense) the given node +hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected ast = any isRegular <$> astConnectedComments ast + where isRegular = (== Nothing) . ExactPrint.Types.commentOrigin . fst + +astConnectedComments + :: Data ast + => GHC.Located ast + -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] +astConnectedComments ast = do anns <- filterAnns ast <$> mAsk - return - $ not - $ null - $ (=<<) extractAllComments - $ Map.elems - $ anns + pure $ extractAllComments =<< Map.elems anns hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsPrior ast = astAnn ast <&> \case Nothing -> False Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors +hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsRest ast = astAnn ast <&> \case + Nothing -> False + Just ann -> any isRegular (extractRestComments ann) + where isRegular = (== Nothing) . ExactPrint.Types.commentOrigin . fst + hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 37724f6..ec3f06f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -33,6 +33,9 @@ import GHC ( runGhc ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn +#if MIN_VERSION_ghc(8,6,0) +import HsExtension (NoExt (..)) +#endif import Name import BasicTypes ( InlinePragma(..) , Activation(..) @@ -62,7 +65,8 @@ layoutDecl d@(L loc decl) = case decl of Left ns -> docLines $ return <$> ns Right n -> return n TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD _ (TyFamInstD{}) -> layoutTyFamInstDWorkaround d + InstD _ (TyFamInstD _ tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d @@ -73,25 +77,12 @@ layoutDecl d@(L loc decl) = case decl of Left ns -> docLines $ return <$> ns Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD (TyFamInstD{}) -> layoutTyFamInstDWorkaround d + InstD (TyFamInstD tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #endif -layoutTyFamInstDWorkaround :: ToBriDoc HsDecl -layoutTyFamInstDWorkaround d = do - -- this is a (temporary (..)) workaround for "type instance" decls - -- that do not round-trip through exactprint properly. - let fixer s = case List.stripPrefix "type " s of - Just rest | not ("instance" `isPrefixOf` rest) -> - "type instance " ++ rest - _ -> s - str <- mAsk <&> \anns -> - intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns - allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) - (foldedAnnKeys d) - False - (Text.pack str) -------------------------------------------------------------------------------- -- Sig @@ -156,24 +147,11 @@ layoutSig lsig@(L _loc sig) = case sig of ] ] ] - else - docAlt - $ [ docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr - , appSep $ docLit $ Text.pack "::" - , docForceSingleline typeDoc - ] - | not hasComments - ] - ++ [ docAddBaseY BrIndentRegular $ docPar - (docWrapNodeRest lsig $ docLit nameStr) - ( docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ) - ] + else layoutLhsAndType + hasComments + (appSep . docWrapNodeRest lsig $ docLit nameStr) + "::" + typeDoc specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String @@ -754,12 +732,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do sharedLhs <- docSharedWrapper id lhs typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ - runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [sharedLhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] - addAlternative $ docAddBaseY BrIndentRegular $ docPar - sharedLhs - (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) + layoutLhsAndType hasComments sharedLhs "=" typeDoc layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr layoutTyVarBndr needsSep lbndr@(L _ bndr) = do @@ -788,6 +761,55 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do ] +-------------------------------------------------------------------------------- +-- TyFamInstDecl +-------------------------------------------------------------------------------- + +layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl +layoutTyFamInstDecl inClass (L loc tfid) = do + let +#if MIN_VERSION_ghc(8,6,0) + linst = L loc (TyFamInstD NoExt tfid) + feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid + lfeqn = L loc feqn +#elif MIN_VERSION_ghc(8,4,0) + linst = L loc (TyFamInstD tfid) + feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid + lfeqn = L loc feqn +#elif MIN_VERSION_ghc(8,2,0) + linst = L loc (TyFamInstD tfid) + lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid + pats = hsib_body boundPats +#else + linst = L loc (TyFamInstD tfid) + lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid + pats = hsib_body boundPats +#endif + docWrapNodePrior linst $ do + nameStr <- lrdrNameToTextAnn name + needsParens <- hasAnnKeyword lfeqn AnnOpenP + let + instanceDoc = if inClass + then docLit $ Text.pack "type" + else docSeq + [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] + lhs = + docWrapNode lfeqn + . appSep + . docWrapNodeRest linst + . docSeq + $ (appSep instanceDoc :) + $ [ docParenL | needsParens ] + ++ [appSep $ docWrapNode name $ docLit nameStr] + ++ intersperse docSeparator (layoutType <$> pats) + ++ [ docParenR | needsParens ] + hasComments <- (||) + <$> hasAnyRegularCommentsConnected lfeqn + <*> hasAnyRegularCommentsRest linst + typeDoc <- docSharedWrapper layoutType typ + layoutLhsAndType hasComments lhs "=" typeDoc + + -------------------------------------------------------------------------------- -- ClsInstDecl -------------------------------------------------------------------------------- @@ -855,12 +877,7 @@ layoutClsInst lcid@(L _ cid) = docLines layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) layoutAndLocateTyFamInsts ltfid@(L loc _) = - L loc <$> layoutTyFamInstDecl ltfid - - -- | Send to ExactPrint then remove unecessary whitespace - layoutTyFamInstDecl :: ToBriDoc TyFamInstDecl - layoutTyFamInstDecl ltfid = - fmap stripWhitespace <$> briDocByExactNoComment ltfid + L loc <$> layoutTyFamInstDecl True ltfid layoutAndLocateDataFamInsts :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) @@ -928,3 +945,23 @@ layoutClsInst lcid@(L _ cid) = docLines isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "data" `Text.isPrefixOf` t') + + +-------------------------------------------------------------------------------- +-- Common Helpers +-------------------------------------------------------------------------------- + +layoutLhsAndType + :: Bool + -> ToBriDocM BriDocNumbered + -> String + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +layoutLhsAndType hasComments lhs sep typeDoc = do + let sepDoc = appSep . docLit $ Text.pack sep + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq [lhs, sepDoc, docForceSingleline typeDoc] + addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols + ColTyOpPrefix + [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] -- 2.30.2 From 621e00bf3f24896d603978c3d4e5fd61dac3841a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Nov 2018 14:53:08 +0100 Subject: [PATCH 230/478] Fix indentation (comments) after "if" (Fixes #167) --- src-literatetests/10-tests.blt | 14 ++++++++++++++ .../Haskell/Brittany/Internal/BackendUtils.hs | 2 -- .../Haskell/Brittany/Internal/Layouters/Expr.hs | 2 +- .../Brittany/Internal/Transformations/Floating.hs | 4 ++++ 4 files changed, 19 insertions(+), 3 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 15a021e..4d274c7 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -516,6 +516,20 @@ myTupleSection = func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) +#test comment-after-then +foo = if True + then + -- iiiiii + "a " + else + "b " + +#test comment-after-if-else-do +func = if cond + then pure 42 + else do + -- test + abc ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 0a2792c..508a18c 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -417,13 +417,11 @@ layoutIndentLevelPushCur = do (Right{}, Just j ) -> j (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y - layoutBaseYPushInternal y layoutIndentLevelPop :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") - layoutBaseYPopInternal layoutIndentLevelPopInternal -- why are comment indentations relative to the previous indentation on -- the first node of an additional indentation, and relative to the outer diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index cab2baa..caf51a7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -563,7 +563,7 @@ layoutExpr lexpr@(L _ expr) = do IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. - runFilteredAlternative $ do + docSetIndentLevel $ runFilteredAlternative $ do -- if _ then _ else _ addAlternativeCond (not hasComments) $ docSeq diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 08a919f..03c6c0c 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -128,6 +128,10 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDBaseYPop (BDAddBaseY ind x) BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) _ -> Nothing stepBO :: BriDoc -> BriDoc stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ -- 2.30.2 From 784e4d0aed5e14768400b79582f4d5f6d6be5948 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 30 Nov 2018 00:17:25 +0100 Subject: [PATCH 231/478] Fix prelude.inc handling in .cabal to make new-install work Hopefully fixes both #162 and #200. --- brittany.cabal | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 9f04fff..c1a31eb 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -25,6 +25,7 @@ extra-doc-files: { } extra-source-files: { src-literatetests/*.blt + srcinc/prelude.inc } source-repository head { @@ -42,9 +43,8 @@ library { Haskell2010 hs-source-dirs: src - install-includes: { - srcinc/prelude.inc - } + include-dirs: + srcinc exposed-modules: { Language.Haskell.Brittany Language.Haskell.Brittany.Internal @@ -130,8 +130,6 @@ library { MultiWayIf KindSignatures } - include-dirs: - srcinc } executable brittany @@ -179,6 +177,7 @@ executable brittany , filepath >=1.4.1.0 && <1.5 } hs-source-dirs: src-brittany + include-dirs: srcinc default-language: Haskell2010 default-extensions: { CPP @@ -249,6 +248,7 @@ test-suite unittests other-modules: TestUtils AsymptoticPerfTests hs-source-dirs: src-unittests + include-dirs: srcinc default-extensions: { CPP @@ -321,6 +321,7 @@ test-suite littests main-is: Main.hs other-modules: hs-source-dirs: src-literatetests + include-dirs: srcinc default-extensions: { CPP @@ -362,6 +363,7 @@ test-suite libinterfacetests main-is: Main.hs other-modules: hs-source-dirs: src-libinterfacetests + include-dirs: srcinc default-extensions: { FlexibleContexts FlexibleInstances -- 2.30.2 From 6c187da8f8166d595f36d6aaf419370283b3d1e9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 30 Nov 2018 22:13:02 +0100 Subject: [PATCH 232/478] Fix cabal file for doc project --- doc-svg-gen/doc-svg-gen.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/doc-svg-gen/doc-svg-gen.cabal b/doc-svg-gen/doc-svg-gen.cabal index 424b841..aff5aa4 100644 --- a/doc-svg-gen/doc-svg-gen.cabal +++ b/doc-svg-gen/doc-svg-gen.cabal @@ -1,7 +1,6 @@ name: doc-svg-gen version: 0.1.0.0 build-type: Simple -extra-source-files: ChangeLog.md cabal-version: >=1.10 executable doc-svg-gen -- 2.30.2 From f68fbb3118aabaa961e24530f0105fc95578a0b5 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sat, 26 Jan 2019 10:55:29 -0800 Subject: [PATCH 233/478] Add build instructions for nix --- .gitignore | 1 + README.md | 6 ++++++ default.nix | 13 +++++++++++++ pkgs.nix | 5 +++++ 4 files changed, 25 insertions(+) create mode 100644 default.nix create mode 100644 pkgs.nix diff --git a/.gitignore b/.gitignore index 906e747..4393459 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,4 @@ local/ cabal.sandbox.config cabal.project.local .ghc.environment.* +result \ No newline at end of file diff --git a/README.md b/README.md index d42d085..da9675b 100644 --- a/README.md +++ b/README.md @@ -94,6 +94,12 @@ log the size of the input, but _not_ the full input/output of requests.) aura -A brittany ~~~~ +- via `nix`: + ~~~.sh + nix build # or 'nix-build' + nix-env -i ./result + ~~~ + # Editor Integration #### Sublime text diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..5c0ccfe --- /dev/null +++ b/default.nix @@ -0,0 +1,13 @@ +{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} +, compiler ? "ghc822" +}: + +pkgs.haskell.packages.${compiler}.developPackage { + root = ./.; + name = "brittany"; + overrides = with pkgs.haskell.lib; self: super: { + }; + source-overrides = { + ghc-exactprint = "0.5.8.0"; + }; +} diff --git a/pkgs.nix b/pkgs.nix new file mode 100644 index 0000000..76cbbb8 --- /dev/null +++ b/pkgs.nix @@ -0,0 +1,5 @@ +{ + url = "https://github.com/nixos/nixpkgs.git"; + ref = "release-18.09"; + rev = "b9fa31cea0e119ecf1867af4944ddc2f7633aacd"; +} -- 2.30.2 From e67a46f2649ee53380f2a7d933588e8587ba0ecd Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Tue, 29 Jan 2019 14:01:29 -0800 Subject: [PATCH 234/478] Refactor nix expressions This way, the default.nix file can be imported to other projects. In order to build brittany, we now need to do `nix build -f release.nix`, which will pull in the version overrides from shell.nix. --- README.md | 2 +- default.nix | 47 ++++++++++++++++++++++++++++++++++++----------- release.nix | 5 +++++ shell.nix | 13 +++++++++++++ 4 files changed, 55 insertions(+), 12 deletions(-) create mode 100644 release.nix create mode 100644 shell.nix diff --git a/README.md b/README.md index da9675b..672de96 100644 --- a/README.md +++ b/README.md @@ -96,7 +96,7 @@ log the size of the input, but _not_ the full input/output of requests.) - via `nix`: ~~~.sh - nix build # or 'nix-build' + nix build -f release.nix # or 'nix-build -f release.nix' nix-env -i ./result ~~~ diff --git a/default.nix b/default.nix index 5c0ccfe..296987a 100644 --- a/default.nix +++ b/default.nix @@ -1,13 +1,38 @@ -{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} -, compiler ? "ghc822" +{ mkDerivation, aeson, base, butcher, bytestring, cmdargs +, containers, czipwith, data-tree-print, deepseq, directory, extra +, filepath, ghc, ghc-boot-th, ghc-exactprint, ghc-paths, hspec +, monad-memo, mtl, multistate, neat-interpolation, parsec, pretty +, random, safe, semigroups, stdenv, strict, syb, text, transformers +, uniplate, unsafe, yaml }: - -pkgs.haskell.packages.${compiler}.developPackage { - root = ./.; - name = "brittany"; - overrides = with pkgs.haskell.lib; self: super: { - }; - source-overrides = { - ghc-exactprint = "0.5.8.0"; - }; +mkDerivation { + pname = "brittany"; + version = "0.11.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson base butcher bytestring cmdargs containers czipwith + data-tree-print deepseq directory extra filepath ghc ghc-boot-th + ghc-exactprint ghc-paths monad-memo mtl multistate + neat-interpolation pretty random safe semigroups strict syb text + transformers uniplate unsafe yaml + ]; + executableHaskellDepends = [ + aeson base butcher bytestring cmdargs containers czipwith + data-tree-print deepseq directory extra filepath ghc ghc-boot-th + ghc-exactprint ghc-paths monad-memo mtl multistate + neat-interpolation pretty safe semigroups strict syb text + transformers uniplate unsafe yaml + ]; + testHaskellDepends = [ + aeson base butcher bytestring cmdargs containers czipwith + data-tree-print deepseq directory extra filepath ghc ghc-boot-th + ghc-exactprint ghc-paths hspec monad-memo mtl multistate + neat-interpolation parsec pretty safe semigroups strict syb text + transformers uniplate unsafe yaml + ]; + homepage = "https://github.com/lspitzner/brittany/"; + description = "Haskell source code formatter"; + license = stdenv.lib.licenses.agpl3; } diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..b37b2ce --- /dev/null +++ b/release.nix @@ -0,0 +1,5 @@ +{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} +, compiler ? "ghc822" +}: + +pkgs.haskell.packages.${compiler}.callPackage ./shell.nix {} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..5c0ccfe --- /dev/null +++ b/shell.nix @@ -0,0 +1,13 @@ +{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} +, compiler ? "ghc822" +}: + +pkgs.haskell.packages.${compiler}.developPackage { + root = ./.; + name = "brittany"; + overrides = with pkgs.haskell.lib; self: super: { + }; + source-overrides = { + ghc-exactprint = "0.5.8.0"; + }; +} -- 2.30.2 From 6aa537089d6e93c8080ef0c009801cfa2b303e8c Mon Sep 17 00:00:00 2001 From: Matt Noonan Date: Mon, 4 Feb 2019 15:10:55 -0500 Subject: [PATCH 235/478] Disable single-line HsApp with argument comments. --- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index caf51a7..dd0639d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -172,9 +172,10 @@ layoutExpr lexpr@(L _ expr) = do _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs + hasComments <- hasAnyCommentsConnected exp2 runFilteredAlternative $ do -- foo x y - addAlternative + addAlternativeCond (not hasComments) $ colsOrSequence $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) -- 2.30.2 From 855160037736898712021d039a29bf8bc9d3ed13 Mon Sep 17 00:00:00 2001 From: Matt Noonan Date: Mon, 4 Feb 2019 22:56:46 -0500 Subject: [PATCH 236/478] Explicitly handle empty HsCase and HsLamCase. --- .../Brittany/Internal/Layouters/Expr.hs | 22 +++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index caf51a7..0982308 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -136,6 +136,15 @@ layoutExpr lexpr@(L _ expr) = do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ XMatchGroup{} -> error "brittany internal error: HsLamCase XMatchGroup" + HsLamCase _ (MG _ (L _ []) _) -> do +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ + HsLamCase (MG (L _ []) _ _ _) -> do +#else /* ghc-8.0 */ + HsLamCase _ (MG (L _ []) _ _ _) -> do +#endif + docSetParSpacing $ docAddBaseY BrIndentRegular $ + (docLit $ Text.pack "\\case {}") +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do @@ -520,6 +529,19 @@ layoutExpr lexpr@(L _ expr) = do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ _ XMatchGroup{} -> error "brittany internal error: HsCase XMatchGroup" + HsCase _ cExp (MG _ (L _ []) _) -> do +#else + HsCase cExp (MG (L _ []) _ _ _) -> do +#endif + cExpDoc <- docSharedWrapper layoutExpr cExp + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do #else HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do -- 2.30.2 From ff7dca9bb55599afe0f76fc2d090e28aa28752bb Mon Sep 17 00:00:00 2001 From: Artem Chernyak Date: Tue, 12 Mar 2019 21:29:12 -0500 Subject: [PATCH 237/478] Added Emacs to Editor Integration --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index d42d085..9383323 100644 --- a/README.md +++ b/README.md @@ -111,6 +111,8 @@ log the size of the input, but _not_ the full input/output of requests.) brittany built in. #### Atom [Atom Beautify](https://atom.io/packages/atom-beautify) supports brittany as a formatter for Haskell. Since the default formatter is set to hindent, you will need to change this setting to brittany, after installing the extension. +#### Emacs + [format-all](https://github.com/lassik/emacs-format-all-the-code) support brittany as the default formatter for Haskell. # Usage -- 2.30.2 From ffc1e6918cbd838c672103a7239c54a596e159c2 Mon Sep 17 00:00:00 2001 From: Tej Chajed Date: Fri, 31 May 2019 17:00:38 -0400 Subject: [PATCH 238/478] Add stack configuration for GHC 8.6 --- .travis.yml | 3 +++ brittany.cabal | 12 ++++++------ stack-8.6.5.yaml | 5 +++++ 3 files changed, 14 insertions(+), 6 deletions(-) create mode 100644 stack-8.6.5.yaml diff --git a/.travis.yml b/.travis.yml index 195c1a2..d1b303b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -95,6 +95,9 @@ matrix: - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml" compiler: ": #stack 8.2.2" addons: {apt: {packages: [libgmp-dev]}} + - env: BUILD=stack ARGS="--stack-yaml stack-8.6.5.yaml" + compiler: ": #stack 8.6.5" + addons: {apt: {packages: [libgmp-dev]}} # Nightly builds are allowed to fail - env: BUILD=stack ARGS="--resolver nightly" diff --git a/brittany.cabal b/brittany.cabal index c1a31eb..5a16f50 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -86,7 +86,7 @@ library { { base >=4.9 && <4.13 , ghc >=8.0.1 && <8.7 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.5.9 + , ghc-exactprint >=0.5.8 && <0.7 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 @@ -99,12 +99,12 @@ library { , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4 , butcher >=1.3.1 && <1.4 - , yaml >=0.8.18 && <0.9 + , yaml >=0.8.18 && <0.12 , aeson >=1.0.1.0 && <1.5 , 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 + , monad-memo >=0.4.1 && <0.6 , unsafe >=0.0 && <0.1 , safe >=0.3.9 && <0.4 , deepseq >=1.4.2.0 && <1.5 @@ -242,7 +242,7 @@ test-suite unittests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.6 + , hspec >=2.4.1 && <2.7 } main-is: TestMain.hs other-modules: TestUtils @@ -314,7 +314,7 @@ test-suite littests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.6 + , hspec >=2.4.1 && <2.7 , filepath , parsec >=3.1.11 && <3.2 } @@ -358,7 +358,7 @@ test-suite libinterfacetests , base , text , transformers - , hspec >=2.4.1 && <2.6 + , hspec >=2.4.1 && <2.7 } main-is: Main.hs other-modules: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml new file mode 100644 index 0000000..2717de3 --- /dev/null +++ b/stack-8.6.5.yaml @@ -0,0 +1,5 @@ +resolver: lts-13.23 + +extra-deps: + - butcher-1.3.2.1 + - multistate-0.8.0.1 -- 2.30.2 From d161648f24705da914b6a09663d2554c0323c34c Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 2 Jun 2019 22:53:00 +0200 Subject: [PATCH 239/478] Allow ghc-exactprint-0.6.1 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index c1a31eb..95f454b 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -86,7 +86,7 @@ library { { base >=4.9 && <4.13 , ghc >=8.0.1 && <8.7 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.5.9 + , ghc-exactprint >=0.5.8 && <0.6.2 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 -- 2.30.2 From bd8b743e3645f2e8a4611aa08761b1319b3aeea0 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 5 Jun 2019 15:42:47 +0200 Subject: [PATCH 240/478] Document terminology "regular comments" --- .../Brittany/Internal/LayouterBasics.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 977e8e8..701339c 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -297,8 +297,20 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast -- | True if there are any regular comments connected to any node below (in AST -- sense) the given node hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsConnected ast = any isRegular <$> astConnectedComments ast - where isRegular = (== Nothing) . ExactPrint.Types.commentOrigin . fst +hasAnyRegularCommentsConnected ast = + any isRegularComment <$> astConnectedComments ast + +-- | Regular comments are comments that are actually "source code comments", +-- i.e. things that start with "--" or "{-". In contrast to comment-annotations +-- used by ghc-exactprint for capturing symbols (and their exact positioning). +-- +-- Only the type instance layouter makes use of this filter currently, but +-- it might make sense to apply it more aggressively or make it the default - +-- I believe that most of the time we branch on the existence of comments, we +-- only care about "regular" comments. We simply did not need the distinction +-- because "irregular" comments are not that common outside of type/data decls. +isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool +isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst astConnectedComments :: Data ast @@ -316,8 +328,7 @@ hasAnyCommentsPrior ast = astAnn ast <&> \case hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyRegularCommentsRest ast = astAnn ast <&> \case Nothing -> False - Just ann -> any isRegular (extractRestComments ann) - where isRegular = (== Nothing) . ExactPrint.Types.commentOrigin . fst + Just ann -> any isRegularComment (extractRestComments ann) hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -- 2.30.2 From ca3c8b6f9eada12dd3747460b3536e0d95c9d627 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 5 Jun 2019 15:56:32 +0200 Subject: [PATCH 241/478] Add one source doc --- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index ec3f06f..9366a6f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -960,8 +960,17 @@ layoutLhsAndType layoutLhsAndType hasComments lhs sep typeDoc = do let sepDoc = appSep . docLit $ Text.pack sep runFilteredAlternative $ do + -- (separators probably are "=" or "::") + -- lhs = type + -- lhs :: type addAlternativeCond (not hasComments) $ docSeq [lhs, sepDoc, docForceSingleline typeDoc] + -- lhs + -- :: typeA + -- -> typeB + -- lhs + -- = typeA + -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] -- 2.30.2 From 09a227fcce36afd3029697e43471b1b9f0390da4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 5 Jun 2019 20:11:01 +0200 Subject: [PATCH 242/478] Add quick regression-test for fixed issue --- src-literatetests/15-regressions.blt | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 080c15e..d402ca7 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -650,3 +650,13 @@ jaicyhHumzo btrKpeyiFej mava = do ) Xcde{} -> (s, Pioemav) pure imomue + +#test issue 214 +-- brittany { lconfig_indentPolicy: IndentPolicyMultiple } +foo = bar + arg1 -- this is the first argument + arg2 -- this is the second argument + arg3 -- this is the third argument, now I'll skip one comment + arg4 + arg5 -- this is the fifth argument + arg6 -- this is the sixth argument -- 2.30.2 From f9d70cf546d3c3f22a74ddba052da08272667561 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 5 Jun 2019 20:11:01 +0200 Subject: [PATCH 243/478] Refactor CPP slightly, Add test-cases --- src-literatetests/10-tests.blt | 39 +++++++++++++++++++ .../Brittany/Internal/Layouters/Expr.hs | 14 ++++++- 2 files changed, 51 insertions(+), 2 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 4d274c7..5b6e0f5 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -531,6 +531,45 @@ func = if cond -- test abc +#test nonempty-case-short +func = case x of + False -> False + True -> True + +#test nonempty-case-long +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True + +#test nonempty-case-long-do +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True + +#test empty-case-short +func = case x of {} + +#test empty-case-long +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} + +#test empty-case-long-do +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 0982308..94c4183 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -136,6 +136,8 @@ layoutExpr lexpr@(L _ expr) = do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ XMatchGroup{} -> error "brittany internal error: HsLamCase XMatchGroup" +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ (L _ []) _) -> do #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ HsLamCase (MG (L _ []) _ _ _) -> do @@ -529,18 +531,26 @@ layoutExpr lexpr@(L _ expr) = do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ _ XMatchGroup{} -> error "brittany internal error: HsCase XMatchGroup" +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ cExp (MG _ (L _ []) _) -> do #else HsCase cExp (MG (L _ []) _ _ _) -> do #endif cExpDoc <- docSharedWrapper layoutExpr cExp - docSetParSpacing - $ docAddBaseY BrIndentRegular + docAlt + [ docAddBaseY BrIndentRegular $ docSeq [ appSep $ docLit $ Text.pack "case" , appSep $ docForceSingleline cExpDoc , docLit $ Text.pack "of {}" ] + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") + ] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do #else -- 2.30.2 From 305f98fad77c9536c25d0c76d7536aad2a7ecc74 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 6 Jun 2019 00:33:17 +0200 Subject: [PATCH 244/478] Update .travis.yml for current ghc versions --- .travis.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index d1b303b..b5b35a0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -59,9 +59,9 @@ matrix: - env: BUILD=cabal GHCVER=8.4.4 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.4.4" addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.6.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.6.2" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.6.5 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.6.5" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.5,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. @@ -95,6 +95,9 @@ matrix: - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml" compiler: ": #stack 8.2.2" addons: {apt: {packages: [libgmp-dev]}} + - env: BUILD=stack ARGS="--stack-yaml stack-8.4.3.yaml" + compiler: ": #stack 8.4.3" + addons: {apt: {packages: [libgmp-dev]}} - env: BUILD=stack ARGS="--stack-yaml stack-8.6.5.yaml" compiler: ": #stack 8.6.5" addons: {apt: {packages: [libgmp-dev]}} -- 2.30.2 From 42f566b94ab24f41d191ae8e91d8fa2f4aba95e7 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 12 Jun 2019 09:17:21 +0200 Subject: [PATCH 245/478] Support QuasiQuotation-splices --- src-literatetests/14-extensions.blt | 35 +++++++++++ src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/Backend.hs | 61 ++++++++++--------- .../Haskell/Brittany/Internal/Config.hs | 2 + .../Haskell/Brittany/Internal/Config/Types.hs | 18 ++++++ .../Brittany/Internal/Layouters/Expr.hs | 14 +++++ .../Brittany/Internal/Transformations/Alt.hs | 32 +++++++++- .../Internal/Transformations/Columns.hs | 1 + .../Haskell/Brittany/Internal/Types.hs | 7 +++ .../Haskell/Brittany/Internal/Utils.hs | 7 ++- 11 files changed, 145 insertions(+), 34 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 9dc0378..e403568 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -95,3 +95,38 @@ spanKey = case foo of spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) spanKey = case foo of (# bar#, baz# #) -> (# baz# +# bar#, bar# #) + + +############################################################################### +## QuasiQuotes +#test quasi-quotes simple 1 +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe + |] + +#test quasi-quotes simple 2 +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe|] + +#test quasi-quotes ignoring layouting +{-# LANGUAGE QuasiQuotes #-} +func = do + let body = [json| + hello + |] + pure True + +#test quasi-quotes ignoring layouting, strict mode +-- brittany { lconfig_allowHangingQuasiQuotes: False } +{-# LANGUAGE QuasiQuotes #-} +func = do + let + body = + [json| + hello + |] + pure True diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 284c696..ef70e44 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -178,6 +178,7 @@ defaultTestConfig = Config , _lconfig_hangingTypeSignature = coerce False , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 3394dc9..bf7a1a3 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -59,6 +59,7 @@ defaultTestConfig = Config , _lconfig_hangingTypeSignature = coerce False , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index d5a2434..8f97171 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -151,6 +151,8 @@ layoutBriDocM = \case mSet $ state { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state } + BDPlain t -> do + layoutWriteAppend t BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state @@ -310,6 +312,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDForceSingleline bd -> rec bd BDForwardLineMode bd -> rec bd BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd @@ -329,35 +332,37 @@ briDocIsMultiLine briDoc = rec briDoc where rec :: BriDoc -> Bool rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ _ _ -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar _ _ _ -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal _ _ _ _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_:_:_) -> True - BDLines [_ ] -> False - BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd - BDDebug _ bd -> rec bd + BDExternal _ _ _ _ -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_ ] -> False + BDLines [] -> error "briDocIsMultiLine BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 464bd3c..89d125e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -75,6 +75,7 @@ staticDefaultConfig = Config , _lconfig_hangingTypeSignature = coerce False , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -177,6 +178,7 @@ cmdlineConfigParser = do , _lconfig_hangingTypeSignature = mempty , _lconfig_reformatModulePreamble = mempty , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index e157c77..a415a08 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -109,6 +109,24 @@ data CLayoutConfig f = LayoutConfig -- > , def -- > ) -- > where + , _lconfig_allowHangingQuasiQuotes :: f (Last Bool) + -- if false, the layouter sees any splices as infinitely big and places + -- them accordingly (in newlines, most likely); This also influences + -- parent nodes. + -- if true, the layouter is free to start a quasi-quotation at the end + -- of a line. + -- + -- false: + -- > let + -- > body = + -- > [json| + -- > hello + -- > |] + -- + -- true: + -- > let body = [json| + -- > hello + -- > |] } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3f1cfb7..74a87af 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -15,6 +15,8 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) import HsSyn import Name @@ -1109,6 +1111,18 @@ layoutExpr lexpr@(L _ expr) = do HsTcBracketOut{} -> do -- TODO briDocByExactInlineOnly "HsTcBracketOut{}" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do +#else + HsSpliceE (HsQuasiQuote _ quoter _loc content) -> do +#endif + allocateNode $ BDFPlain + (Text.pack + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]") HsSpliceE{} -> do -- TODO briDocByExactInlineOnly "HsSpliceE{}" lexpr diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index b9458fb..22d0555 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -288,6 +288,7 @@ transformAlts = mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } return $ x BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX BDFAnnotationPrior annKey bd -> do acp <- mGet mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } @@ -337,9 +338,13 @@ transformAlts = acp :: AltCurPos <- mGet tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp reWrap . BDFDebug s <$> rec bd - processSpacingSimple :: (MonadMultiReader - Config m, - MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m () + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () processSpacingSimple bd = getSpacing bd >>= \case LineModeInvalid -> error "processSpacingSimple inv" LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do @@ -455,6 +460,9 @@ getSpacing !bridoc = rec bridoc BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False _ -> VerticalSpacing 999 VerticalSpacingParNone False + BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of + [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd @@ -584,6 +592,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc if i1 < i2 then Smaller else Bigger (p1, p2) -> if p1 == p2 then Smaller else Unequal else Unequal + let allowHangingQuasiQuotes = + config + & _conf_layout + & _lconfig_allowHangingQuasiQuotes + & confUnpack let -- this is like List.nub, with one difference: if two elements -- are unequal only in _vs_paragraph, with both ParAlways, we -- treat them like equals and replace the first occurence with the @@ -729,6 +742,19 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1 ] -> VerticalSpacing + (Text.length t1) + VerticalSpacingParNone + False + (t1 : _) -> VerticalSpacing + (Text.length t1) + (VerticalSpacingParAlways 0) + True + | allowHangingQuasiQuotes + ] BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 471ac67..31ec86a 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -125,6 +125,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDForceSingleline{} -> Nothing BDForwardLineMode{} -> Nothing BDExternal{} -> Nothing + BDPlain{} -> Nothing BDLines{} -> Nothing BDAnnotationPrior{} -> Nothing BDAnnotationKW{} -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index e54d35e..8aad965 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -243,6 +243,8 @@ data BriDoc -- to be printed via exactprint Bool -- should print extra comment ? Text + | BDPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc @@ -289,6 +291,8 @@ data BriDocF f -- to be printed via exactprint Bool -- should print extra comment ? Text + | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) @@ -323,6 +327,7 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDAlt alts) = plate BDAlt ||* alts uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd @@ -355,6 +360,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen BDFForwardLineMode bd -> BDForwardLineMode $ rec bd BDFExternal k ks c t -> BDExternal k ks c t + BDFPlain t -> BDPlain t BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd @@ -391,6 +397,7 @@ briDocSeqSpine = \case BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts BDForwardLineMode bd -> briDocSeqSpine bd BDExternal{} -> () + BDPlain{} -> () BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationRest _annKey bd -> briDocSeqSpine bd diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index b454890..dfd28c3 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -24,6 +24,7 @@ module Language.Haskell.Brittany.Internal.Utils , FirstLastView(..) , splitFirstLast , lines' + , showOutputable ) where @@ -69,8 +70,8 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords showSDoc_ :: GHC.SDoc -> String showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags -showGhc :: (GHC.Outputable a) => a -> String -showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags +showOutputable :: (GHC.Outputable a) => a -> String +showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y @@ -124,7 +125,7 @@ customLayouterF anns layoutF = srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" ++ showGhc ss ++ "}" + $ "{" ++ showOutputable ss ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where -- 2.30.2 From 2b95e747cd2c8fd505ac7037904a9906369e3766 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 12 Jun 2019 10:34:02 +0200 Subject: [PATCH 246/478] Update stack.yaml to allow testing nightly again --- stack.yaml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/stack.yaml b/stack.yaml index 1ce5fc3..10eddb2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,11 @@ -resolver: lts-11.1 +resolver: lts-13.25 extra-deps: - - czipwith-1.0.1.0 - - butcher-1.3.1.1 - - ghc-exactprint-0.5.8.0 + - multistate-0.8.0.2 + - butcher-1.3.2.3 + - deque-0.4.2.3 + - strict-list-0.1.4 + - ghc-exactprint-0.5.8.2 packages: - . -- 2.30.2 From b95bc09a9d9b07b5b3dbfb6eff7ddd9d50f38b82 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 12 Jun 2019 12:58:08 +0200 Subject: [PATCH 247/478] Bump upper bound to hspec<2.8 --- brittany.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index ee5275e..649358b 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -242,7 +242,7 @@ test-suite unittests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.7 + , hspec >=2.4.1 && <2.8 } main-is: TestMain.hs other-modules: TestUtils @@ -314,7 +314,7 @@ test-suite littests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.7 + , hspec >=2.4.1 && <2.8 , filepath , parsec >=3.1.11 && <3.2 } @@ -358,7 +358,7 @@ test-suite libinterfacetests , base , text , transformers - , hspec >=2.4.1 && <2.7 + , hspec >=2.4.1 && <2.8 } main-is: Main.hs other-modules: -- 2.30.2 From 3288ef3bd4982c055f86d6b984a3e6880402d370 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 15 Jun 2019 14:38:48 +0200 Subject: [PATCH 248/478] For funs with multiple matches, use the match id as id (fixes #234) --- src-literatetests/15-regressions.blt | 8 ++++++++ .../Haskell/Brittany/Internal/Layouters/Decl.hs | 15 +++++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index d402ca7..be4bc55 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -660,3 +660,11 @@ foo = bar arg4 arg5 -- this is the fifth argument arg6 -- this is the sixth argument + +#test issue 234 + +True `nand` True = False +nand _ _ = True + +nor False False = True +_ `nor` _ = False diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 9366a6f..c7a7d04 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -294,7 +294,7 @@ layoutPatternBind -> BriDocNumbered -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered -layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do +layoutPatternBind funId binderDoc lmatch@(L _ match) = do let pats = m_pats match #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let (GRHSs _ grhss whereBinds) = m_grhss match @@ -303,6 +303,17 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do #endif patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match + mIdStr <- case match of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId +#elif MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ + Match (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.4 */ + Match (FunRhs matchId _ _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId +#else + Match (FunBindMatch matchId _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId +#endif + _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of (Just idStr, p1 : pr) | isInfix -> docCols @@ -321,7 +332,7 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) - let alignmentToken = if null pats then Nothing else mIdStr + let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch layoutPatternBindFinal alignmentToken binderDoc -- 2.30.2 From b2d8a1ed51b88894d336707580e4aa2ba0aaab33 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 16 Jun 2019 21:54:55 +0200 Subject: [PATCH 249/478] Bump to 0.12.0.0, Update copyright, readme, changelog --- ChangeLog.md | 39 ++++++++++++++++++++++++++++ README.md | 69 +++++++++++++++++++++++++++----------------------- brittany.cabal | 5 ++-- 3 files changed, 80 insertions(+), 33 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 5dcb20c..0f193e8 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,44 @@ # Revision history for brittany +## 0.12.0.0 -- June 2019 + +* Support for ghc-8.6 (basic support, not necessarily all new syntactic + extensions) +* Support -XExplicitNamespaces and -XPatternSynonyms +* Allow a --dry-run sort of operation via flag "-c/--check-mode" + (thanks to Doug Beardsley @mightybyte) +* Include file name in errors about unsupported syntax nodes (thanks to @5outh) +* Partially implement layouting class instances: Layouts children, but + falls back on ghc-exactprint for the instance head + (thanks to Rupert Horlick @ruhatch) +* Implement layouting for type synonyms (thanks to Rupert Horlick @ruhatch) +* Support -XMagicHash, -XUnboxedTuples (thanks to Sergey Vinokurov @sergv) +* Support -XQuasiQuotes (no formatting applied to the splices; they are simply + retained without causing the dreaded "Unknown construct: HsSpliceE{}") + - `lconfig_allowHangingQuasiQuotes` controls whether multi-line + QuasiQuotes are allowed to start at the end of the current line, or + whether they are always placed in new lines. +* Bugfixes: + - Fix rare-case alignment bug with IndentPolicyMultiple (#144) + - Make inline layout config apply to module header (#151) + - Fix unaligned import-hiding layout (#150) + - Fix idempotence violation for comments around if-then-else (#167) + - Fix comments having an effect on far-away parent node's layout (#159) + - Fix imports of type operators ("symbolic data types") + (thanks to Phil Hazelden @ChickenProp) + - Work around GHC and cabal-install misfeature ".ghc.environment files" + that could break brittany in unexpected and hard-to-understand ways + - Stop removing empty lines before `where` keyword in a couple of cases + - Fix functions with mixing prefix/infix style causing error (#234) +* Changes to layout: + - Align usage of spaces for record update vs record construction (#126) + - More indentation to import-hiding-paragraph (follow-up to #150 fix) + - Record construction and update now are layouted in the same way + (thanks to Evan Rutledge Borden @eborden) + - Stop allowing single-line layout when there are comments between + arguments (#214) (thanks to @matt-noonan) +* Various build-instructions and editor integrations + ## 0.11.0.0 -- May 2018 * Support for ghc-8.4 diff --git a/README.md b/README.md index f51e5fc..8b3a21d 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.0`, `8.2` and `8.4`. +- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. @@ -58,41 +58,15 @@ log the size of the input, but _not_ the full input/output of requests.) # Installation -- 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 - ~~~~ - -- via `cabal new-build` - - ~~~~.sh - cabal unpack brittany - cd brittany-0.11.0.0 - # 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/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/ - ~~~~ - -- via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) +- via `stack` ~~~~.sh stack install brittany # --resolver lts-10.0 ~~~~ - (earlier ltss did not include `brittany` yet, but the repo should contain a - `stack.yaml` that works with ghc-8.0.) - -- on ArchLinux via [the brittany AUR package](https://aur.archlinux.org/packages/brittany/) - using `aura`: - ~~~~.sh - aura -A brittany - ~~~~ + If you use an lts that includes brittany this should just work; otherwise + you may want to clone the repo and try again (there are several stack.yamls + included). - via `nix`: ~~~.sh @@ -100,6 +74,39 @@ log the size of the input, but _not_ the full input/output of requests.) nix-env -i ./result ~~~ +- via `cabal v1-build` + + ~~~~.sh + # optionally: + # mkdir brittany + # cd brittany + # cabal sandbox init + cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_x + ~~~~ + +- via `cabal v2-install` + + ~~~~.sh + cabal v2-install brittany + ~~~~ + +- via `cabal v2-build`, should v2-install not work: + + ~~~~.sh + cabal unpack brittany + cd brittany-0.11.0.0 + # cabal new-configure -w $PATH_TO_GHC_8_x + cabal new-build exe:brittany + # and it should be safe to just copy the executable, e.g. + cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/ + ~~~~ + +- on ArchLinux via [the brittany AUR package](https://aur.archlinux.org/packages/brittany/) + using `aura`: + ~~~~.sh + aura -A brittany + ~~~~ + # Editor Integration #### Sublime text diff --git a/brittany.cabal b/brittany.cabal index 649358b..cf8c054 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.11.0.0 +version: 0.12.0.0 synopsis: Haskell source code formatter description: { See . @@ -12,7 +12,8 @@ license: AGPL-3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner -copyright: Copyright (C) 2016-2018 Lennart Spitzner +copyright: Copyright (C) 2016-2019 Lennart Spitzner + Copyright (C) 2019 PRODA LTD category: Language build-type: Simple cabal-version: 1.18 -- 2.30.2 From c818cdae52fe73d46f995475844c75010896daae Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 17 Jun 2019 18:32:01 +0200 Subject: [PATCH 250/478] Update copyright notice in readme also --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 8b3a21d..7ca55ba 100644 --- a/README.md +++ b/README.md @@ -176,7 +176,8 @@ a good amount of high-level documentation at # License -Copyright (C) 2016-2018 Lennart Spitzner +Copyright (C) 2016-2019 Lennart Spitzner\ +Copyright (C) 2019 PRODA LTD This program is free software: you can redistribute it and/or modify it under the terms of the -- 2.30.2 From 56f93ba3bb732d8f58db28975136247695f01fd3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 18 Jun 2019 15:38:19 +0200 Subject: [PATCH 251/478] readme: Update paragraph on maintenance/contribution --- README.md | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 7ca55ba..3ecf7b0 100644 --- a/README.md +++ b/README.md @@ -162,14 +162,22 @@ log the size of the input, but _not_ the full input/output of requests.) # Feature Requests, Contribution, Documentation -This currently is a one-person project in the sense that 90% of the code is -written by one person. And (unfortunately) it is not my job to keep improving -this project. Please forgive that as a consequence my time to invest on new -features is rather limited. +For a long time this project has had a single maintainer, and as a consequence +there have been some mildly large delays for reacting to feature requests +and even PRs. -Nonetheless I consider it "in active development" :) +Sorry about that. -One way of speeding things up is to make your own contributions. There is +The good news is that this project is getting sponsored by PRODA LTD, and two +previous contributors, Evan Borden and Taylor Fausak, have agreed on helping +with organisational aspects. Thanks! + +Still, this project has a long queue of very sensible feature requests, so it +may take some time until new ones get our attention. But with the help of +the co-maintainers, at least the reaction-times on PRs and the frequency +of releases should improve significantly. + +If you are interested in making your own contributions, there is a good amount of high-level documentation at [the documentation index](doc/implementation/index.md) -- 2.30.2 From 988d5b435390f2391583b09e79304814c35dfd2b Mon Sep 17 00:00:00 2001 From: Evan Borden Date: Sun, 23 Jun 2019 19:31:05 -0500 Subject: [PATCH 252/478] Add support for OverloadedLabels `OverloadedLabels` is a simple enough extension to parse and format. It is becoming more common with use of `generic-lens`. Since it can be treated as a `HsVar` its implementation only requires using `docLit`, along with some marshalling for dealing with `FastString`. --- src-literatetests/14-extensions.blt | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 12 +++++++++--- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index e403568..12facda 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -130,3 +130,13 @@ func = do hello |] pure True + +############################################################################### +## OverloadedLabels +#test bare label +{-# LANGUAGE OverloadedLabels #-} +foo = #bar + +#test applied and composed label +{-# LANGUAGE OverloadedLabels #-} +foo = #bar . #baz $ fmap #foo xs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 74a87af..d08824b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -55,9 +55,15 @@ layoutExpr lexpr@(L _ expr) = do HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr - HsOverLabel{} -> do - -- TODO - briDocByExactInlineOnly "HsOverLabel{}" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsOverLabel _ext _reboundFromLabel name -> +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ + HsOverLabel _reboundFromLabel name -> +#else /* ghc-8.0 */ + HsOverLabel name -> +#endif + let label = FastString.unpackFS name + in docLit . Text.pack $ '#' : label HsIPVar{} -> do -- TODO briDocByExactInlineOnly "HsOverLabel{}" lexpr -- 2.30.2 From a79b5e1a4bfd10dd1375db516099c3fcc8f53b52 Mon Sep 17 00:00:00 2001 From: pepe iborra Date: Sun, 14 Jul 2019 16:02:55 +0100 Subject: [PATCH 253/478] Add support for Implicit Params I don't know what I'm doing, but it type checks Closes #246 --- src-literatetests/14-extensions.blt | 16 +++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 28 +++++++++++++++++-- .../Brittany/Internal/Layouters/Expr.hs | 10 +++++-- 3 files changed, 49 insertions(+), 5 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 12facda..1dc5cf8 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -140,3 +140,19 @@ foo = #bar #test applied and composed label {-# LANGUAGE OverloadedLabels #-} foo = #bar . #baz $ fmap #foo xs + +############################################################################### +## ImplicitParams + +#test IP usage +{-# LANGUAGE ImplicitParams #-} +foo = ?bar + +#test IP binding +{-# LANGUAGE ImplicitParams #-} +foo = let ?bar = Foo in value + +#test IP type signature +{-# LANGUAGE ImplicitParams #-} +foo :: (?bar::Bool) => () +foo = () \ No newline at end of file diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index c7a7d04..9a81727 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -32,6 +32,7 @@ import GHC ( runGhc , AnnKeywordId(..) ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) +import qualified FastString import HsSyn #if MIN_VERSION_ghc(8,6,0) import HsExtension (NoExt (..)) @@ -231,6 +232,23 @@ layoutBind lbind@(L _ bind) = case bind of hasComments _ -> Right <$> unknownNodeError "" lbind +layoutIPBind :: ToBriDoc IPBind +layoutIPBind lipbind@(L _ bind) = case bind of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + XIPBind{} -> unknownNodeError "XIPBind" lipbind + IPBind _ (Right _) _ -> error "unreachable" + IPBind _ (Left (L _ (HsIPName name))) expr -> do +#else + IPBind (Right _) _ -> error "unreachable" + IPBind (Left (L _ (HsIPName name))) expr -> do +#endif + ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name + binderDoc <- docLit $ Text.pack "=" + exprDoc <- layoutExpr expr + hasComments <- hasAnyCommentsBelow lipbind + layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments + + data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) | BagSig (LSig GhcPs) @@ -268,8 +286,14 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}" (L noSrcSpan x) #endif - x@(HsIPBinds{}) -> - Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + x@(HsIPBinds _ XHsIPBinds{}) -> + Just . (: []) <$> unknownNodeError "XHsIPBinds" (L noSrcSpan x) + HsIPBinds _ (IPBinds _ bb) -> +#else + HsIPBinds (IPBinds bb _) -> +#endif + Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index d08824b..43797cd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -64,9 +64,13 @@ layoutExpr lexpr@(L _ expr) = do #endif let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label - HsIPVar{} -> do - -- TODO - briDocByExactInlineOnly "HsOverLabel{}" lexpr +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIPVar _ext (HsIPName name) -> +#else + HsIPVar (HsIPName name) -> +#endif + let label = FastString.unpackFS name + in docLit . Text.pack $ '?' : label #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsOverLit _ olit -> do #else -- 2.30.2 From 6c69388d73b34f112ef68961353fc697a53799ac Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 19 Jul 2019 00:12:04 +0200 Subject: [PATCH 254/478] Make errors more descriptive This is defensive against GHC API guarantees. --- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 9a81727..0dc05a7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -236,10 +236,10 @@ layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ XIPBind{} -> unknownNodeError "XIPBind" lipbind - IPBind _ (Right _) _ -> error "unreachable" + IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" IPBind _ (Left (L _ (HsIPName name))) expr -> do #else - IPBind (Right _) _ -> error "unreachable" + IPBind (Right _) _ -> error "brittany internal error: IPBind Right" IPBind (Left (L _ (HsIPName name))) expr -> do #endif ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name -- 2.30.2 From c36ecd47181d52e3b3fb648b869d5acdd215155b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jonas=20Sch=C3=BCrmann?= Date: Thu, 22 Aug 2019 12:53:17 +0200 Subject: [PATCH 255/478] README: Fix typo --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 3ecf7b0..117911c 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ This project's goals roughly are to: (but excluding `-XCPP` which is too hard); - Retain newlines and comments unmodified; - Be clever about using the available horizontal space while not overflowing - the column maximum if it cannot be avoided; + the column maximum unless it cannot be avoided; - Be clever about aligning things horizontally (this can be turned off completely however); - Have linear complexity in the size of the input. -- 2.30.2 From bd10c3c4ef8bcd7e7e5d95c2b6e9e6dcea90cfc6 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 21 Jun 2019 11:06:47 +0200 Subject: [PATCH 256/478] Update copyright in commandline notices --- src-brittany/Main.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 8bbd111..dd4871f 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -114,7 +114,8 @@ helpDoc = PP.vcat $ List.intersperse licenseDoc :: PP.Doc licenseDoc = PP.vcat $ List.intersperse (PP.text "") - [ parDoc $ "Copyright (C) 2016-2017 Lennart Spitzner" + [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" + , parDoc $ "Copyright (C) 2019 PRODA LTD" , parDocW [ "This program is free software: you can redistribute it and/or modify" , "it under the terms of the GNU Affero General Public License," @@ -194,7 +195,8 @@ mainCmdParser helpDesc = do when printVersion $ do do putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2018 Lennart Spitzner" + putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" + putStrLn $ "Copyright (C) 2019 PRODA LTD" putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do -- 2.30.2 From 033fdc6517eb8ecd85bb2c0e3fd9343c486776fb Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 23 Jun 2019 17:15:59 +0200 Subject: [PATCH 257/478] Apply brittany to Main.hs --- src-brittany/Main.hs | 72 +++++++++++++++++++++----------------------- 1 file changed, 35 insertions(+), 37 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index dd4871f..357a4cc 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -57,8 +57,7 @@ data WriteMode = Display | Inplace instance Read WriteMode where readPrec = val "display" Display <|> val "inplace" Inplace - where - val iden v = ReadPrec.lift $ ReadP.string iden >> return v + where val iden v = ReadPrec.lift $ ReadP.string iden >> return v instance Show WriteMode where show Display = "display" @@ -166,11 +165,11 @@ mainCmdParser helpDesc = do "c" ["check-mode"] (flagHelp - (PP.vcat - [ PP.text "check for changes but do not write them out" - , PP.text "exits with code 0 if no changes necessary, 1 otherwise" - ] - ) + (PP.vcat + [ PP.text "check for changes but do not write them out" + , PP.text "exits with code 0 if no changes necessary, 1 otherwise" + ] + ) ) writeMode <- addFlagReadParam "" @@ -226,17 +225,18 @@ mainCmdParser helpDesc = do $ trace (showConfigYaml config) $ return () - results <- zipWithM (coreIO putStrErrLn config (suppressOutput || checkMode)) - inputPaths - outputPaths + results <- zipWithM + (coreIO putStrErrLn config (suppressOutput || checkMode)) + inputPaths + outputPaths if checkMode - then when (any (==Changes) (Data.Either.rights results)) $ - System.Exit.exitWith (System.Exit.ExitFailure 1) + then when (any (== Changes) (Data.Either.rights results)) + $ System.Exit.exitWith (System.Exit.ExitFailure 1) else case results of - xs | all Data.Either.isRight xs -> pure () - [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + xs | all Data.Either.isRight xs -> pure () + [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) data ChangeStatus = Changes | NoChanges @@ -278,20 +278,19 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = viaDebug = config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic @@ -308,7 +307,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = (hackTransform inputString) return (parseRes, Text.pack inputString) Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc + parseRes <- parseModule ghcOptions p cppCheckFunc inputText <- Text.IO.readFile p -- The above means we read the file twice, but the -- GHC API does not really expose the source it @@ -359,13 +358,12 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s - let - out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ fmap hackF - $ TextL.splitOn (TextL.pack "\n") outRaw - else outRaw + let out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ fmap hackF + $ TextL.splitOn (TextL.pack "\n") outRaw + else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out -- 2.30.2 From 4de2862a04cfdf18ea30f0101c1f0620f57dde60 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 23 Jun 2019 17:21:02 +0200 Subject: [PATCH 258/478] Add commandline flag --no-user-config Stops brittany from trying to read a user-global config flag. Together with --config-file, this can be used to pass one single config to brittany, thereby controlling exactly and explicit what the inputs of brittany are. Should be useful for testing stuff that might depend on config. --- src-brittany/Main.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 357a4cc..527d2e8 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -146,6 +146,7 @@ mainCmdParser helpDesc = do printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty + noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty configPaths <- addFlagStringParams "" ["config-file"] "PATH" @@ -217,7 +218,11 @@ mainCmdParser helpDesc = do else pure configPaths config <- - runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) + runMaybeT + (if noUserConfig + then readConfigs cmdlineConfig configsToLoad + else readConfigsWithUserConfig cmdlineConfig configsToLoad + ) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x -- 2.30.2 From 698356a88027af109cf6e1b6ef285c34563285b5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 5 Jul 2019 19:45:27 +0200 Subject: [PATCH 259/478] Increase the timeout of one of the perf-tests --- src-unittests/AsymptoticPerfTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs index 09b4f2b..778e13a 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -22,7 +22,7 @@ import TestUtils asymptoticPerfTest :: Spec asymptoticPerfTest = do it "1000 do statements" - $ roundTripEqualWithTimeout 1000000 + $ roundTripEqualWithTimeout 1500000 $ (Text.pack "func = do\n") <> Text.replicate 1000 (Text.pack " statement\n") it "1000 do nestings" -- 2.30.2 From f2893898790594cc2020c7d4077f732db89383bc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 28 Aug 2019 14:48:11 +0200 Subject: [PATCH 260/478] Fix comment wandering left inside instance decls --- src-literatetests/10-tests.blt | 7 +++++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 1 + 2 files changed, 8 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index da8c3ee..11724ac 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1065,6 +1065,13 @@ type ((a :+: b) c) = (a, c) instance MyClass Int where myMethod x = x + 1 +#test simple-method-comment + +instance MyClass Int where + myMethod x = + -- insightful comment + x + 1 + #test simple-method-signature instance MyClass Int where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 0dc05a7..c2cbbae 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -858,6 +858,7 @@ layoutClsInst :: ToBriDoc ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular + $ docSetIndentLevel $ docSortedLines $ fmap layoutAndLocateSig (cid_sigs cid) ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) -- 2.30.2 From c97f6dd5591feb7e7773d59bcee182a7cc23a1c3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 2 Sep 2019 13:58:08 +0200 Subject: [PATCH 261/478] Update cabal instructions --- README.md | 41 ++++++++++++++++++----------------------- 1 file changed, 18 insertions(+), 23 deletions(-) diff --git a/README.md b/README.md index 117911c..df7b22e 100644 --- a/README.md +++ b/README.md @@ -74,32 +74,27 @@ log the size of the input, but _not_ the full input/output of requests.) nix-env -i ./result ~~~ -- via `cabal v1-build` +- via `cabal` - ~~~~.sh - # optionally: - # mkdir brittany - # cd brittany - # cabal sandbox init - cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_x - ~~~~ + Due to constant changes to the cabal UI, I have given up on making sure + these instructions work before releases. Please do not expect these + instructions to be up-to-date; they may produce incomprehensible error + messages, they may be broken otherwise, they may work now but break with + the next cabal release. Thanks for your understanding, and feel free to + open issues for any problems you encounter. -- lennart -- via `cabal v2-install` + If you are using cabal-3.0, using + `cabal install brittany --installdir=$HOME/.cabal/bin` + might work. Keep in mind that cabal merely puts a symlink to the "store" + into the installdir, so you have to re-install if you ever clean your + store. On cabal-2.4, try `cabal v2-install brittany`. On cabal-2.2 or + earlier you might be succesful using + ```cabal new-build exe:brittany; cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/```. + Alternatively, you can also use the v1-approach with sandboxes as + `cabal v1-sandbox init; cabal v1-install brittany --bindir=$HOME/.cabal/bin`. - ~~~~.sh - cabal v2-install brittany - ~~~~ - -- via `cabal v2-build`, should v2-install not work: - - ~~~~.sh - cabal unpack brittany - cd brittany-0.11.0.0 - # cabal new-configure -w $PATH_TO_GHC_8_x - cabal new-build exe:brittany - # and it should be safe to just copy the executable, e.g. - cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/ - ~~~~ + (TODO: These instructions are more confusing than helpful. I am inclined + to just remove them.) - on ArchLinux via [the brittany AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`: -- 2.30.2 From 91d6e18abaabcd71dbd45b9b89ee6bd3ecbd516f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 31 Aug 2019 23:19:59 +0200 Subject: [PATCH 262/478] Adapt to ghc-8.8 (deps are not ready though) --- brittany.cabal | 8 +- src-literatetests/10-tests.blt | 2 + src-literatetests/15-regressions.blt | 2 +- .../Haskell/Brittany/Internal/Backend.hs | 10 +- .../Brittany/Internal/ExactPrintUtils.hs | 5 +- .../Brittany/Internal/Layouters/Decl.hs | 45 ++++++- .../Brittany/Internal/Layouters/Expr.hs | 14 ++- .../Brittany/Internal/Layouters/Pattern.hs | 27 +++-- .../Brittany/Internal/Layouters/Type.hs | 110 +++++++++--------- .../Haskell/Brittany/Internal/Prelude.hs | 14 ++- 10 files changed, 155 insertions(+), 82 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index cf8c054..7eb6e46 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -84,10 +84,10 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.9 && <4.13 - , ghc >=8.0.1 && <8.7 + { base >=4.9 && <4.14 + , ghc >=8.0.1 && <8.9 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.6.2 + , ghc-exactprint >=0.5.8 && <0.6.3 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 @@ -112,7 +112,7 @@ library { , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.0.1 && <8.7 + , ghc-boot-th >=8.0.1 && <8.9 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 } diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 11724ac..f833847 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1220,6 +1220,7 @@ type instance MyFam Bool = String type instance MyFam (Maybe a) = a -> Bool #test simple-typefam-instance-parens +#pending the parens cause problems since ghc-8.8 type instance (MyFam (String -> Int)) = String @@ -1237,6 +1238,7 @@ type instance MyFam Bool -- This is an odd one = AnotherType -- Here's another #test simple-typefam-instance-parens-comment +#pending the parens cause problems since ghc-8.8 -- | A happy family type instance (MyFam Bool) -- This is an odd one diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index be4bc55..0d40271 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -607,7 +607,7 @@ go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 #test issue 89 - type-family-instance -type instance (XPure StageParse) = () +type instance XPure StageParse = () type Pair a = (a, a) #test issue 144 diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 8f97171..e4872f2 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -173,14 +173,10 @@ layoutBriDocM = \case -- layoutResetSepSpace priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - do + when (not $ comment == "(" || comment == ")") $ do case comment of ('#':_) -> layoutMoveToCommentPos y (-999) -- ^ evil hack for CPP - "(" -> pure () - ")" -> pure () - -- ^ these two fix the formatting of parens - -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -217,7 +213,7 @@ layoutBriDocM = \case Nothing -> pure () Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - do + when (not $ comment == "(" || comment == ")") $ do -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) @@ -251,7 +247,7 @@ layoutBriDocM = \case Nothing -> pure () Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - do + when (not $ comment == "(" || comment == ")") $ do case comment of ('#':_) -> layoutMoveToCommentPos y (-999) -- ^ evil hack for CPP diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 0c4f901..1fabf9c 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -276,7 +276,10 @@ foldedAnnKeys ast = SYB.everything 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 + , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x + -- for some reason, ghc-8.8 has forgotten how to infer the type of l, + -- even though it is passed to mkAnnKey above, which only accepts + -- SrcSpan. ] ) ast diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index c2cbbae..67e9000 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -20,6 +20,7 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Layouters.Type import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint @@ -743,7 +744,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do let (a : b : rest) = vars hasOwnParens <- hasAnnKeywordComment a AnnOpenP -- This isn't quite right, but does give syntactically valid results - let needsParens = not $ null rest || hasOwnParens + let needsParens = not (null rest) || hasOwnParens docSeq $ [ docLit $ Text.pack "type" , docSeparator @@ -800,24 +801,36 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do -- TyFamInstDecl -------------------------------------------------------------------------------- + + layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl layoutTyFamInstDecl inClass (L loc tfid) = do let -#if MIN_VERSION_ghc(8,6,0) +#if MIN_VERSION_ghc(8,8,0) + linst = L loc (TyFamInstD NoExt tfid) + feqn@(FamEqn _ name bndrsMay pats _fixity typ) = hsib_body $ tfid_eqn tfid + -- bndrsMay isJust e.g. with + -- type instance forall a . MyType (Maybe a) = Either () a + lfeqn = L loc feqn +#elif MIN_VERSION_ghc(8,6,0) linst = L loc (TyFamInstD NoExt tfid) feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid + bndrsMay = Nothing lfeqn = L loc feqn #elif MIN_VERSION_ghc(8,4,0) linst = L loc (TyFamInstD tfid) feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid + bndrsMay = Nothing lfeqn = L loc feqn #elif MIN_VERSION_ghc(8,2,0) linst = L loc (TyFamInstD tfid) lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid + bndrsMay = Nothing pats = hsib_body boundPats #else linst = L loc (TyFamInstD tfid) lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid + bndrsMay = Nothing pats = hsib_body boundPats #endif docWrapNodePrior linst $ do @@ -828,15 +841,23 @@ layoutTyFamInstDecl inClass (L loc tfid) = do then docLit $ Text.pack "type" else docSeq [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] + makeForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered + makeForallDoc bndrs = do + bndrDocs <- layoutTyVarBndrs bndrs + docSeq + ( [docLit (Text.pack "forall")] + ++ processTyVarBndrsSingleline bndrDocs + ) lhs = docWrapNode lfeqn . appSep . docWrapNodeRest linst . docSeq - $ (appSep instanceDoc :) - $ [ docParenL | needsParens ] + $ [appSep instanceDoc] + ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] + ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] - ++ intersperse docSeparator (layoutType <$> pats) + ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] hasComments <- (||) <$> hasAnyRegularCommentsConnected lfeqn @@ -845,6 +866,20 @@ layoutTyFamInstDecl inClass (L loc tfid) = do layoutLhsAndType hasComments lhs "=" typeDoc +#if MIN_VERSION_ghc(8,8,0) +layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats pats = pats <&> \case + HsValArg tm -> layoutType tm + HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] + -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change + -- is a bit strange. Hopefully this does not ignore any important + -- annotations. + HsArgPar _l -> error "brittany internal error: HsArgPar{}" +#else +layoutHsTyPats :: [LHsType GhcPs] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats pats = layoutType <$> pats +#endif + -------------------------------------------------------------------------------- -- ClsInstDecl -------------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 43797cd..6fad40b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -278,7 +278,11 @@ layoutExpr lexpr@(L _ expr) = do expDoc1 expDoc2 ] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ + HsAppType _ _ XHsWildCardBndrs{} -> + error "brittany internal error: HsAppType XHsWildCardBndrs" + HsAppType _ exp1 (HsWC _ ty1) -> do +#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsAppType XHsWildCardBndrs{} _ -> error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType (HsWC _ ty1) exp1 -> do @@ -1034,7 +1038,13 @@ layoutExpr lexpr@(L _ expr) = do Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) #endif recordExpression indentPolicy lexpr rExprDoc rFs -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */ + ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) -> + error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" + ExprWithTySig _ _ XHsWildCardBndrs{} -> + error "brittany internal error: ExprWithTySig XHsWildCardBndrs" + ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do +#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ -> error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" ExprWithTySig XHsWildCardBndrs{} _ -> diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index e77856c..234dac7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Pattern ( layoutPat @@ -13,7 +14,13 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, ol_val ) +import GHC ( Located + , runGhc + , GenLocated(L) + , moduleNameString + , ol_val + ) +import qualified GHC import HsSyn import Name import BasicTypes @@ -33,8 +40,8 @@ import Language.Haskell.Brittany.Internal.Layouters.Type -- ^^^^^^^^^^ this part -- We will use `case .. of` as the imagined prefix to the examples used in -- the different cases below. -layoutPat :: ToBriDocC (Pat GhcPs) (Seq BriDocNumbered) -layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of +layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) +layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -51,7 +58,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of #endif fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ + ParPat _ inner -> do +#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ParPat _ inner -> do #else /* ghc-8.0 8.2 8.4 */ ParPat inner -> do @@ -177,7 +186,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of #endif -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ + SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do +#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do @@ -242,13 +253,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- else -- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n -- endif - _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat + _ -> return <$> briDocByExactInlineOnly "some unknown pattern" (ghcDL lpat) colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend - :: Located (Pat GhcPs) + :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do @@ -260,7 +271,7 @@ wrapPatPrepend pat prepElem = do return $ x1' Seq.<| xR wrapPatListy - :: [Located (Pat GhcPs)] + :: [LPat GhcPs] -> String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 5bbbc4c..ef34942 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -2,6 +2,8 @@ module Language.Haskell.Brittany.Internal.Layouters.Type ( layoutType + , layoutTyVarBndrs + , processTyVarBndrsSingleline ) where @@ -32,21 +34,19 @@ import DataTreePrint 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) #if MIN_VERSION_ghc(8,6,0) HsTyVar _ promoted name -> do - t <- lrdrNameToTextAnn name - case promoted of - Promoted -> docSeq - [ docSeparator - , docTick - , docWrapNode name $ docLit t - ] - NotPromoted -> docWrapNode name $ docLit t -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#else /* ghc-8.2 ghc-8.4 */ HsTyVar promoted name -> do +#endif t <- lrdrNameToTextAnn name case promoted of +#if MIN_VERSION_ghc(8,8,0) + IsPromoted -> docSeq +#else /* ghc-8.2 8.4 8.6 */ Promoted -> docSeq +#endif [ docSeparator , docTick , docWrapNode name $ docLit t @@ -63,32 +63,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do #endif typeDoc <- docSharedWrapper layoutType typ2 - tyVarDocs <- bndrs `forM` \case -#if MIN_VERSION_ghc(8,6,0) - (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar _ lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" -#else - (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) -#endif + tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline _ -> id let - tyVarDocLineList = tyVarDocs >>= \case - (tname, Nothing) -> [docLit $ Text.pack " " <> tname] - (tname, Just doc) -> [ docLit $ Text.pack " (" - <> tname - <> Text.pack " :: " - , docForceSingleline $ doc - , docLit $ Text.pack ")" - ] + tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs forallDoc = docAlt [ let open = docLit $ Text.pack "forall" @@ -142,7 +123,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of else let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open]++tyVarDocLineList++[close]) + in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) , docForceSingleline contextDoc , docLit $ Text.pack " => " , docForceSingleline typeDoc @@ -172,31 +153,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsForAllTy bndrs typ2 -> do #endif typeDoc <- layoutType typ2 - tyVarDocs <- bndrs `forM` \case -#if MIN_VERSION_ghc(8,6,0) - (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar _ lrdrName kind)) -> do - d <- layoutType kind - return $ (lrdrNameToText lrdrName, Just $ return d) - (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" -#else - (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do - d <- layoutType kind - return $ (lrdrNameToText lrdrName, Just $ return d) -#endif + tyVarDocs <- layoutTyVarBndrs bndrs let maybeForceML = case typ2 of (L _ HsFunTy{}) -> docForceMultiline _ -> id - let - tyVarDocLineList = tyVarDocs >>= \case - (tname, Nothing) -> [docLit $ Text.pack " " <> tname] - (tname, Just doc) -> [ docLit $ Text.pack " (" - <> tname - <> Text.pack " :: " - , docForceSingleline doc - , docLit $ Text.pack ")" - ] + let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs docAlt -- forall x . x [ docSeq @@ -771,3 +732,46 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of else docLit $ Text.pack "*" XHsType{} -> error "brittany internal error: XHsType" #endif +#if MIN_VERSION_ghc(8,8,0) + HsAppKindTy _ ty kind -> do + t <- docSharedWrapper layoutType ty + k <- docSharedWrapper layoutType kind + docAlt + [ docSeq + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar + t + (docSeq [docLit $ Text.pack "@", k ]) + ] +#endif + +layoutTyVarBndrs + :: [LHsTyVarBndr GhcPs] + -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] +layoutTyVarBndrs = mapM $ \case +#if MIN_VERSION_ghc(8,6,0) + (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" +#else + (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) +#endif + +processTyVarBndrsSingleline + :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] +processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case + (tname, Nothing) -> [docLit $ Text.pack " " <> tname] + (tname, Just doc) -> + [ docLit $ Text.pack " (" <> tname <> Text.pack " :: " + , docForceSingleline $ doc + , docLit $ Text.pack ")" + ] diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 6b93bf0..453f076 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -18,7 +18,10 @@ import HsExtension as E ( GhcPs ) #endif import RdrName as E ( RdrName ) - +#if MIN_VERSION_ghc(8,8,0) +import qualified GHC ( dL, HasSrcSpan, SrcSpanLess ) +#endif +import qualified GHC ( Located ) -- more general: @@ -410,3 +413,12 @@ type instance IdP GhcPs = RdrName type GhcPs = RdrName #endif + + +#if MIN_VERSION_ghc(8,8,0) +ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) +ghcDL = GHC.dL +#else /* ghc-8.0 8.2 8.4 8.6 */ +ghcDL :: GHC.Located a -> GHC.Located a +ghcDL x = x +#endif -- 2.30.2 From 670b796edb708fa3e2418c8e672324e3c721de2a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 31 Aug 2019 23:22:21 +0200 Subject: [PATCH 263/478] Add ghc-8.8.1 to travis script --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml index b5b35a0..4a6f6c2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -80,6 +80,9 @@ matrix: - env: BUILD=canew GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal new 8.2.2" addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=canew GHCVER=8.8.1 CABALVER=3.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal new 8.8.1" + addons: {apt: {packages: [cabal-install-3.0,ghc-8.8.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} ##### STACK ##### @@ -111,6 +114,7 @@ matrix: #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=stack ARGS="--resolver nightly" - env: BUILD=stack ARGS="" + - env: BUILD=canew GHCVER=8.8.1 CABALVER=3.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 before_install: # Using compiler above sets CC to an invalid value, so unset it -- 2.30.2 From 8861f16624947b6c75a2c1b1c85e8f26b746c1ec Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 2 Sep 2019 17:02:20 +0200 Subject: [PATCH 264/478] Fix comment handling with let-in --- src-literatetests/10-tests.blt | 33 ++++++++ .../Brittany/Internal/Layouters/Expr.hs | 75 ++++++++++--------- 2 files changed, 72 insertions(+), 36 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index f833847..7516fd4 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -612,6 +612,39 @@ func = _ -> True ] +############################################################################### +############################################################################### +############################################################################### +#group expression.let +############################################################################### +############################################################################### +############################################################################### + +#test single-bind-comment-long +testMethod foo bar baz qux = + let x = undefined foo bar baz qux qux baz bar :: String + -- some comment explaining the in expression + in undefined foo x :: String + +#test single-bind-comment-short +testMethod foo bar baz qux = + let x = undefined :: String + -- some comment explaining the in expression + in undefined :: String + +#test single-bind-comment-before +testMethod foo bar baz qux = + -- some comment explaining the in expression + let x = undefined :: String in undefined :: String + +#test multiple-binds-comment +foo foo bar baz qux = + let a = 1 + b = 2 + c = 3 + -- some comment explaining the in expression + in undefined :: String + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 6fad40b..3ecf133 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -725,10 +725,10 @@ layoutExpr lexpr@(L _ expr) = do #else HsLet binds exp1 -> do #endif - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. - mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) - =<< layoutLocalBinds binds + hasComments <- hasAnyCommentsBelow lexpr + mBindDocs <- fmap (fmap (fmap pure)) $ layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a ifIndentFreeElse x y = @@ -745,37 +745,38 @@ layoutExpr lexpr@(L _ expr) = do -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. docSetBaseAndIndent $ case mBindDocs of - Just [bindDoc] -> docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline bindDoc - , appSep $ docLit $ Text.pack "in" - , docForceSingleline expDoc1 - ] - , docLines - [ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) - ] - , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY expDoc1) - ] - ] - ] + Just [bindDoc] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ appSep $ docLit $ Text.pack "let" + , docNodeAnnKW lexpr (Just AnnLet) + $ appSep $ docForceSingleline bindDoc + , appSep $ docLit $ Text.pack "in" + , docForceSingleline expDoc1 + ] + addAlternative $ docLines + [ docNodeAnnKW lexpr (Just AnnLet) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) + ] + , docAlt + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY expDoc1) + ] + ] Just bindDocs@(_:_) -> runFilteredAlternative $ do --either -- let @@ -805,7 +806,8 @@ layoutExpr lexpr@(L _ expr) = do IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds IndentPolicyFree -> docLines - [ docSeq + [ docNodeAnnKW lexpr (Just AnnLet) + $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines bindDocs ] @@ -816,7 +818,8 @@ layoutExpr lexpr@(L _ expr) = do ] addAlternative $ docLines - [ docAddBaseY BrIndentRegular + [ docNodeAnnKW lexpr (Just AnnLet) + $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ bindDocs) -- 2.30.2 From 702b993dabe54efdf0736a469df40e04dc2c9a8b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 3 Sep 2019 00:23:58 +0200 Subject: [PATCH 265/478] Fix prefix operator pattern-match invalid result --- src-literatetests/15-regressions.blt | 4 ++++ src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0d40271..325e18a 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -668,3 +668,7 @@ nand _ _ = True nor False False = True _ `nor` _ = False + +#test issue 256 prefix operator match + +f ((:) a as) = undefined diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 234dac7..cd1b31e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -86,7 +86,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of -- return $ (x1' Seq.<| middle) Seq.|> xN' ConPatIn lname (PrefixCon args) -> do -- Abc a b c -> expr - let nameDoc = lrdrNameToText lname + nameDoc <- lrdrNameToTextAnn lname argDocs <- layoutPat `mapM` args if null argDocs then return <$> docLit nameDoc -- 2.30.2 From 6879436e6721adb3b91f3b32072cd02019b20e8a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 3 Sep 2019 01:04:25 +0200 Subject: [PATCH 266/478] Fix lambdas with lazy/bang pattern as first argument --- src-literatetests/15-regressions.blt | 8 +++++++ .../Brittany/Internal/Layouters/Expr.hs | 22 ++++++++++++++++++- 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 325e18a..6a25c6c 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -672,3 +672,11 @@ _ `nor` _ = False #test issue 256 prefix operator match f ((:) a as) = undefined + +#test issue 228 lambda plus lazy or bang pattern + +{-# LANGUAGE BangPatterns #-} +a = \x -> x +b = \ ~x -> x +c = \ !x -> x +d = \(~x) -> x diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3ecf133..dac10c9 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -101,7 +101,27 @@ layoutExpr lexpr@(L _ expr) = do , L _ (GRHS [] body) <- lgrhs #endif -> do - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let shouldPrefixSeparator = case p of + (L _ LazyPat{}) -> isFirst + (L _ BangPat{}) -> isFirst + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body let funcPatternPartLine = docCols ColCasePattern -- 2.30.2 From 0795a398060d37090e51ced5adf1457610443bf0 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Sep 2019 00:48:45 +0200 Subject: [PATCH 267/478] Fix infix matches with more than 2 args, fixes #219 --- src-literatetests/10-tests.blt | 9 +++++++ .../Brittany/Internal/Layouters/Decl.hs | 24 +++++++++++++++---- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 7516fd4..1b152f5 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -330,6 +330,15 @@ x *** y = x #test symbol prefix (***) x y = x +#test infix more args simple +(f >=> g) k = f k >>= g + +#test infix more args alignment +(Left a <$$> Left dd) e f = True +(Left a <$$> Right d ) e f = True +(Right a <$$> Left d ) e f = False +(Right a <$$> Right dd) e f = True + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 67e9000..6d9a1f5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -341,11 +341,25 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1 : pr) | isInfix -> docCols - ColPatternsFuncInfix - ( [appSep $ docForceSingleline p1, appSep $ docLit idStr] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) + (Just idStr, p1:p2:pr) | isInfix -> if null pr + then + docCols ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else + docCols ColPatternsFuncInfix + ( [docCols ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR + ] + ] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix -- 2.30.2 From a98d643a6211db66ab585c27b9afa5066bbe00c4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 29 Sep 2019 13:02:55 +0200 Subject: [PATCH 268/478] Disable perf test by default via new cabal flag --- .travis.yml | 7 ++++--- brittany.cabal | 7 ++++++- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4a6f6c2..1a26676 100644 --- a/.travis.yml +++ b/.travis.yml @@ -176,7 +176,7 @@ install: set -ex case "$BUILD" in stack) - stack -j$JOBS --no-terminal --install-ghc $ARGS test --bench --only-dependencies + stack -j$JOBS --no-terminal --install-ghc $ARGS test --bench --only-dependencies --flag brittany:brittany-test-perf ;; cabal*) cabal --version @@ -219,6 +219,7 @@ install: echo 'packages: .' > cabal.project echo 'package brittany' > cabal.project.local echo ' ghc-options: -Werror -with-rtsopts=-N1' >> cabal.project.local + echo ' flags: +brittany-test-perf' >> cabal.project.local rm -f cabal.project.freeze cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep @@ -231,11 +232,11 @@ script: set -ex case "$BUILD" in stack) - better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts=-N1" + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts=-N1" --flag brittany:brittany-test-perf ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi - cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging + cabal configure --enable-tests --enable-benchmarks -v --flags="brittany-test-perf" # -v2 provides useful information for debugging better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) time cabal test --ghc-options="-with-rtsopts=-N1" ;; diff --git a/brittany.cabal b/brittany.cabal index 7eb6e46..f65c1e6 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -39,6 +39,11 @@ flag brittany-dev-lib default: False manual: True +flag brittany-test-perf + description: determines if performance test suite is enabled + default: False + manual: True + library { default-language: Haskell2010 @@ -205,7 +210,7 @@ executable brittany } test-suite unittests - if flag(brittany-dev-lib) { + if flag(brittany-dev-lib) || !flag(brittany-test-perf) { buildable: False } else { buildable: True -- 2.30.2 From b656b8cc2720f19ee41ec091b245b48f62e54f57 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 29 Sep 2019 18:17:52 +0200 Subject: [PATCH 269/478] Bump to 0.12.1.0; Update changelog --- ChangeLog.md | 21 +++++++++++++++++++++ brittany.cabal | 2 +- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 0f193e8..c1328c3 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,26 @@ # Revision history for brittany +## 0.12.1.0 -- September 2019 + +* Support for OverloadedLabels extension + (thanks to Evan Rutledge Borden @eborden) +* Support for Implicit Params extension (thanks to pepe iborra @pepeiborra) +* Add flag `--no-user-config` to enable only using manually passed config +* Theoretically support ghc-8.8 (brittany itself now compiles with 8.8, but + you need certain patched dependencies) +* Disable the performance test suite by default to prevent spurious failures + on certain CI setups. The github/travis brittany CI still has all tests + enabled. See the `brittany-test-perf` flag in the cabal file. +* Bugfixes: + - Fix one wandering-comment bug for let-in expressions + - Fix invalid result for prefix operator pattern matches + - Fix lambda expression with laziness/strictness annotation + - Fix parenthesis handling for infix pattern matches with 3+ arguments +* Changes to layouting behaviour: + - For pattern matching and data/instance definitions, the usage of + parenthesis is now "normalized", i.e. superfluous parens are removed by + brittany. + ## 0.12.0.0 -- June 2019 * Support for ghc-8.6 (basic support, not necessarily all new syntactic diff --git a/brittany.cabal b/brittany.cabal index f65c1e6..0bda1ee 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.12.0.0 +version: 0.12.1.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 3482f6a36d3c30c6d0a9e9cf68f062953b3a65d6 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 29 Sep 2019 18:24:13 +0200 Subject: [PATCH 270/478] Bump semigroups dependency bound --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 0bda1ee..3374405 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -114,7 +114,7 @@ library { , unsafe >=0.0 && <0.1 , safe >=0.3.9 && <0.4 , deepseq >=1.4.2.0 && <1.5 - , semigroups >=0.18.2 && <0.19 + , semigroups >=0.18.2 && <0.20 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.9 -- 2.30.2 From 89b7655bac0e0ff8ac9a2f6f23bcff9f77a151af Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 29 Sep 2019 21:43:47 +0200 Subject: [PATCH 271/478] Fix support for ghc-8.8 --- .travis.yml | 1 - ChangeLog.md | 3 +-- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 5 +++-- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 1a26676..4651e64 100644 --- a/.travis.yml +++ b/.travis.yml @@ -114,7 +114,6 @@ matrix: #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=stack ARGS="--resolver nightly" - env: BUILD=stack ARGS="" - - env: BUILD=canew GHCVER=8.8.1 CABALVER=3.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 before_install: # Using compiler above sets CC to an invalid value, so unset it diff --git a/ChangeLog.md b/ChangeLog.md index c1328c3..8254a36 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,12 +2,11 @@ ## 0.12.1.0 -- September 2019 +* Support ghc-8.8 * Support for OverloadedLabels extension (thanks to Evan Rutledge Borden @eborden) * Support for Implicit Params extension (thanks to pepe iborra @pepeiborra) * Add flag `--no-user-config` to enable only using manually passed config -* Theoretically support ghc-8.8 (brittany itself now compiles with 8.8, but - you need certain patched dependencies) * Disable the performance test suite by default to prevent spurious failures on certain CI setups. The github/travis brittany CI still has all tests enabled. See the `brittany-test-perf` flag in the cabal file. diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index dac10c9..60be59f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Expr ( layoutExpr @@ -112,8 +113,8 @@ layoutExpr lexpr@(L _ expr) = do -- by wrapping it in docSeq below. We _could_ add alignments for -- stuff like lists-of-lambdas. Nothing terribly important..) let shouldPrefixSeparator = case p of - (L _ LazyPat{}) -> isFirst - (L _ BangPat{}) -> isFirst + (ghcDL -> L _ LazyPat{}) -> isFirst + (ghcDL -> L _ BangPat{}) -> isFirst _ -> False patDocSeq <- layoutPat p fixed <- case Seq.viewl patDocSeq of -- 2.30.2 From 17055479d33f16c33a133cd5b3be5ffe9e5107b4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 29 Sep 2019 22:21:01 +0200 Subject: [PATCH 272/478] Try fixing CI, ghc-8.8 seems to use more heap --- .travis.yml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4651e64..ae64c83 100644 --- a/.travis.yml +++ b/.travis.yml @@ -200,7 +200,7 @@ install: echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M500M -RTS"; + cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M700M -RTS"; fi # snapshot package-db on cache miss @@ -216,9 +216,9 @@ install: cabal --version travis_retry cabal update -v echo 'packages: .' > cabal.project - echo 'package brittany' > cabal.project.local - echo ' ghc-options: -Werror -with-rtsopts=-N1' >> cabal.project.local - echo ' flags: +brittany-test-perf' >> cabal.project.local + echo 'package brittany' > cabal.project.local + echo ' ghc-options: -Werror -with-rtsopts=-N1 -j1 +RTS -M700M -RTS' >> cabal.project.local + echo ' flags: +brittany-test-perf' >> cabal.project.local rm -f cabal.project.freeze cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep @@ -231,12 +231,12 @@ script: set -ex case "$BUILD" in stack) - better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts=-N1" --flag brittany:brittany-test-perf + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M700M -RTS -Werror -with-rtsopts=-N1" --flag brittany:brittany-test-perf ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi cabal configure --enable-tests --enable-benchmarks -v --flags="brittany-test-perf" # -v2 provides useful information for debugging - better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) + better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M700M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) time cabal test --ghc-options="-with-rtsopts=-N1" ;; cabaldist) @@ -247,12 +247,12 @@ script: # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && - (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M -RTS") + (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M700M -RTS") ;; canew) - better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks - better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks - time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" + better_wait cabal new-build -j$JOBS --disable-tests --disable-benchmarks + better_wait cabal new-build -j$JOBS --enable-tests --enable-benchmarks + time cabal new-test -j1 ;; esac set +ex -- 2.30.2 From 38f77f6c5e04883dcbda60286ce88e83275009ab Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 29 Sep 2019 23:24:29 +0200 Subject: [PATCH 273/478] Update stack.yaml to allow compilation with ghc-8.8 --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 10eddb2..7ff28c9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,7 +5,7 @@ extra-deps: - butcher-1.3.2.3 - deque-0.4.2.3 - strict-list-0.1.4 - - ghc-exactprint-0.5.8.2 + - ghc-exactprint-0.6.2 packages: - . -- 2.30.2 From 9d0669d6a61d104cff4620784a315cc296f114f0 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Nov 2019 12:07:41 +0100 Subject: [PATCH 274/478] Fix typo in ChangeLog.md --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 8254a36..3230921 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -84,7 +84,7 @@ CONFIG is either: 1) one or more flags in the form of what brittany accepts - on the commandline, e.g. "-- columns 50", or + on the commandline, e.g. "--columns 50", or 2) one or more specifications in the form of what brittany accepts in its config files for the layouting config (a one-line yaml document), e.g. "{ lconfig_cols: 50 }" -- 2.30.2 From 974826f98fa9f08e659dc334edda61bb5c7cfa49 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Nov 2019 12:08:16 +0100 Subject: [PATCH 275/478] Fix whitespace regression on forall+constraint type sig --- src-literatetests/15-regressions.blt | 4 ++++ src/Language/Haskell/Brittany/Internal/Layouters/Type.hs | 7 +++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 6a25c6c..761dfb5 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -680,3 +680,7 @@ a = \x -> x b = \ ~x -> x c = \ !x -> x d = \(~x) -> x + +#test type signature with forall and constraint +{-# LANGUAGE RankNTypes #-} +func :: forall b . Show b => b -> String diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index ef34942..cf9d10c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -766,12 +766,15 @@ layoutTyVarBndrs = mapM $ \case return $ (lrdrNameToText lrdrName, Just $ d) #endif +-- there is no specific reason this returns a list instead of a single +-- BriDoc node. processTyVarBndrsSingleline :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case - (tname, Nothing) -> [docLit $ Text.pack " " <> tname] + (tname, Nothing) -> [docSeparator, docLit tname] (tname, Just doc) -> - [ docLit $ Text.pack " (" <> tname <> Text.pack " :: " + [ docSeparator + , docLit $ Text.pack "(" <> tname <> Text.pack " :: " , docForceSingleline $ doc , docLit $ Text.pack ")" ] -- 2.30.2 From 41750dc8a83c98f2d7918c1865a8125da4ff96e5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 18 Nov 2019 11:26:18 +0100 Subject: [PATCH 276/478] Add doc chapter on exactprinting, plus minor doc fixups --- doc/implementation/exactprinting.md | 412 ++++++++++++++++++++++++++++ doc/implementation/index.md | 5 + doc/implementation/theory.md | 25 +- 3 files changed, 435 insertions(+), 7 deletions(-) create mode 100644 doc/implementation/exactprinting.md diff --git a/doc/implementation/exactprinting.md b/doc/implementation/exactprinting.md new file mode 100644 index 0000000..3f99acc --- /dev/null +++ b/doc/implementation/exactprinting.md @@ -0,0 +1,412 @@ +# Exactprinting + +Brittany uses the `ghc-exactprint` library/wrapper around the GHC API to +parse haskell source code into a syntax tree and into "annotations". The +unannotated syntax tree would lose information, such as the exact (relative) +position in the source text, or any comments; this is what annotations provide. + +Following that name, we'll call "exactprinting" the aspect of reproducing +comments and relative positions - most importantly additional newlines - while +round-tripping through brittany. The focus is not on the API of the +`ghc-exactprint` library, but on the corresponding data-flow through brittany. + +**Take note that the `--dump-bridoc-*` output filters out the constructors +responsible for comments and for applying DeltaPositions.** +This is done to keep the output more readable, but could confuse you if you +try to understand how comments work. + +## TLDR - Practical Suggestions for Implementing Layouters + +This advice does not explain how comments work, but if you are implementing +a layouter it might cover most cases without requiring you to understand the +details. + +- Ideally, we should wrap the `BriDoc` of any construct that as a location + (i.e. has the form `(L _ something)`) (and consequently has an `AnnKey`) + using `docWrapNode`. As an example, look at the `layoutExpr` function and + how it applies `docWrapNode lexpr $ ..` right at the top. + +- If we have not done the above, it is somewhat likely that comments + "get eaten". For such cases: + + 1. Take a small reproduction case + + 1. Throw it at `brittany --dump-ast-full` and see where the comment is + in the syntax tree. See where the corresponding syntax node is + consumed/transformed by brittany and wrap it with `docWrapNode`. + + 1. If it is unclear what alternative (of a `docAlt` or + `runFilteredAlternative`) applies, try inserting `docDebug "myLabel"` + nodes to track down which alternative applies. + +- For comments that _do_ appear in the output but at the wrong location, there + are two classes of problems: Firstly we have comments that move "down" past + other stuff (even switching order of comments is possible). Use the steps + from the last item to figure out which syntax tree constructor is relevant, + and try inserting `docMoveToKWDP` or replace `docWrapNode` with a manually + refined combination of `docWrapNodePrior` and `docWrapNodeRest`. + +- For comments that _do_ appear in the output in roughly the right position, + only with the wrong indentation, the cause most likely is a + mis-interpretation of DPs that can be fixed by inserting a + `docSetIndentLevel` at the right position - right before printing the + thing that provides the "layouting rule" indentation, i.e. the body of a + `do`/`let`/`where` block. + +- There is one other cause for off-by-one errors in comment position: + Whitespace. In general, layouters should prefer to use `docSeparator` to + insert space between syntax elements rather than including spaces in + literal strings. As an example, use `docSeq [docLit "then", docSeparator]` + or the equivalent `appSep (docLit "then")` rather than `docLit "then "`. + The reason is that comment positions are relative to the last non-whitespace, + and `docSeparator` is interpreted in just the right fashion: It inserts + a whitespace, but keeps track of the correct comment offset. (Also, + subsequent `docSeparators` are merged into one.) + +- If all of this fails, read below, bother the maintainers and/or make use of + the more advanced debugging features (there is a `#define` in + `BackendUtils.hs` that you can turn on to insert all kinds of verbose + output in-line with the actual output). + +## A Small Example + +~~~~.hs +main = do + putStr "hello" -- very suspense + putStrLn " world" --nice +~~~~ + +If you pass this to `brittany --dump-ast-full` you'll see .. a 100 line syntax +tree. Yeah, raw syntax tree are a bit unwieldly. + +(btw I'd use `clipread | brittany --dump-ast-full` for that purpose, where +`clipread` boils down to `xclip -o -selection clipboard`. If you have not set +up that script on your system, you really should.) + +To simplify this slightly, we will focus down on just the syntax tree of +the `do` block, which is the `HsDo` constructor. + +~~~~ +---- ast ---- +A Just (Ann (DP (0,0)) [] [] [((AnnComment (Comment "--nice" stdin:3:21-26 Nothing)),DP (0,1)),((G AnnEofPos),DP (1,0))] Nothing Nothing) + HsModule + .. + [ A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) + ValD + FunBind + A Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + Unqual {OccName: main} + MG + A Nothing + [ A Just (Ann (DP (0,0)) [] [] [((G AnnEqual),DP (0,1))] Nothing Nothing) + Match + FunRhs + ..main.. + Prefix + NoSrcStrict + [] + GRHSs + [ A Just (Ann (DP (0,-1)) [] [] [] Nothing Nothing) + GRHS + [] + A Just (Ann (DP (0,1)) [] [] [((G AnnDo),DP (0,0))] Nothing Nothing) + HsDo + DoExpr + A Nothing + [ A Just (Ann (DP (1,2)) [] [] [] Nothing Nothing) + BodyStmt + A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) + HsApp + ..putStr.. + .."hello".. + .. + .. + , A Just (Ann (DP (1,0)) [((Comment "-- very suspense" stdin:2:18-33 Nothing),DP (0,1))] [] [] Nothing Nothing) + BodyStmt + A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) + HsApp + ..putStrLn.. + .." world".. + .. + .. + ] + ] + A (Nothing) (EmptyLocalBinds) + ] + FromSource + WpHole + [] + ] + .. +~~~~ + +So this is a haskell module, `HsModule` containing a function bind `FunBind` +containing a match group, containing a Match, containing some right-hand-side +expression which in this case is just a do block `HsDo` which contains two +applications `HsApp` of a function `putStr(Ln)` plus some string literal. + +There is no need to understand this, as long as you can roughly see how this +representation corresponds to the input source code. + +For the purpose of exactprinting, what we need to look at are the annotations. +The `ghc-exactprint` library returns the syntax tree and annotations as two +different entities: +- [You can start looking at the module level](https://downloads.haskell.org/ghc/latest/docs/html/libraries/ghc-8.8.1/HsSyn.html#v:HsModule) +and work your way down to any syntactical construct from there; +- The [Annotation type and its `Ann` constructor](https://hackage.haskell.org/package/ghc-exactprint-0.6.2/docs/Language-Haskell-GHC-ExactPrint-Types.html#t:Annotation). + +In the above `--dump-ast-full` output these two are mixed together using the +fake `A` constructor that is just a pair of a `Maybe Annotation` and of one +node in the syntax tree. It was produced by recursively printing the syntax +tree, and for each node `n` we print `A (getAnnotation n) n`. So let's focus +on the `Annotation` type. + +## The `ghc-exactprint` Annotation Type + +~~~~.hs +Ann + { annEntryDelta :: !DeltaPos + , annPriorComments :: ![(Comment, DeltaPos)] + , annFollowingComments :: ![(Comment, DeltaPos)] + , annsDP :: ![(KeywordId, DeltaPos)] + , annSortKey :: !(Maybe [SrcSpan]) + , annCapturedSpan :: !(Maybe AnnKey) + } +~~~~ + +But please refer to [the ghc-exactprint docs](https://hackage.haskell.org/package/ghc-exactprint-0.6.2/docs/Language-Haskell-GHC-ExactPrint-Types.html#t:Annotation) for the fully commented version. + +A few things to point out: + +- There are _three_ constructors that contain the `Comment` type in that + constructor. `annPriorComments` and `annFollowingComments` are obvious, but + a third hides behind the `KeywordId` type. Source code comments may appear + in one of these three locations. +- The `DeltaPos` type and its `DP` constructor can be seen in the above output + everywhere. It contains information about relative positioning of both + comments and syntax nodes. Please test what changes if you insert a newline + before `putStrLn`, or add spaces before one of the comments, and see how the + `--dump-ast-full` output changes. +- The exact semantics of the `DP` value, especially when it comes to + indentation, are a source of constant joy. If the values don't make sense, + you are on the right track. Just figure out what DP is connected to what + change in the syntax tree for now. +- We have two comments in the source code, which appear in opposite order + in the `--dump-ast-full` output. The reason is that comments mostly appear + in the middle of two AST nodes, and it is somewhat arbitary whether we + connected them as an "after" comment of the first or as an "before" comment + of the second node. And keep in mind that we have a third constructor that + can contain comments that are somewhere in the "middle" of a node, too. +- We have `DP`s with negative offsets. Did I mention how much fun `DP`s are? + I have no idea where the above `-1` comes from. +- The `annsDP` field may also contain the `DP`s of syntax that is somewhere + "in the middle" of a syntax node, e.g. the position of the `else` keyword. + + We will discuss the semantics of `DP` further down below. + +## Data-Flow of a Comment When Round-Tripping + +Parsing with `ghc-exactprint` returns both a syntax tree and a map of +annotations (`Map AnnKey Annotation`). Let's consider just the comment +"-- very suspense" in the above example: The annotations map would contain +the following mapping: + +~~~~ +AnnKey {stdin:3:3-19} (CN "BodyStmt") + -> Ann { annEntryDelta = DP (1,0) + , annPriorComments = + [((Comment "-- very suspense" stdin:2:18-33 Nothing),DP (0,1))] + , annFollowingComments = [] + , annsDB = [] + , annSortKey = Nothing + , annCapturedSpan = Nothing + } +~~~~ + +where the `AnnKey` is connected to the syntax node `BodyStmt` with the given +source location. + +Brittany keeps the annotations map around, and the `BriDoc` structure contains +nodes that have `AnnKey` values, i.e. the `BriDoc` nested documented structure +similarly only contains references into the annotations map. The corresponding +constructors of the `BriDoc(F)` type are: + +~~~~.hs +data BriDoc + = .. + | BDAnnotationPrior AnnKey BriDoc + | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc + | BDAnnotationRest AnnKey BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset + | .. +~~~~ + +when rendering a `BriDoc` to text, the semantics of the above nodes can be +described roughly like this: +- `render (BDAnnotationPrior annkey bd)` extracts the "before" type comments + under the given `annkey` from the annotations map (this is a stateful + process - they are really removed from the map). It renders these comments. + If we are in a new line, we respect the `annEntryDelta :: DeltaPos` value + to insert newlines. The "if in a new line" check prevents us from inserting + newlines in the case that brittany chose to transform a multi-line layout + into a single-line layout. + + Then we recursively process `render bd`. +- `render (BDAnnotationsKW annkey mkwId bd)` similarly first renders the comments + extracted from the annotations map under the given `annkey` before calling + `render bd`. For example, this would allow us to print the comments _before_ + the closing bracket `]` of an empty list literal e.g. + `[{-put numbers here to do X-}]`. +- `render (BDMoveToKWDP annkey kwId xToo bd` moves to the relative position of + the given keyword before continuing with `render bd`. + It is used for example to insert newlines before a `where` keyword to + match those of the original source code. +- `render (BDAnnotationsRest annkey bd)` first calls `render bd` and _then_ + takes _any remaining comments_ it can find in the annotations map under the + given `annkey` and prints them. + +### Some Notes to This Design + +- We heavily rely on the `ghc-exactprint` library and its types and + their semantics. We could define our own data structures to capture comments + and whitespace offsets. While this could allow us to make the later steps + of the process easier by more closely matching the information we need when + rendering a `BriDoc` document, it would involve a mildly complex + extra transformation step from `ghc-exactprint` annotations to hypothetical + `brittany` annotations. + +- For those cases where we rely on `ghc-exactprint` to output syntax that + `brittany` does not know yet, it is mandatory that we keep the annotations + around. + +- We make the rendering stateful in the annotations. The main advantage to + this is that we can keep track of any comments that have not yet been + reproduced in the output, and as a last resort append them at the end. The + effect of that is that comments "move" down in the document when brittany is + not exact, but at least it does not "eat" comments. The latter can still + happen though if we forget to include a given `AnnKey` at all in the `BriDoc` + document. + + Of course this is a bit yucky, but it seems to be a sensible measure for + the long transitioning period where `brittany` is not perfect. + +- It may be surprising to nest things like we do in the `BriDoc` type. + The intuitive document representation for something like + + ~~~~.hs + -- before + foo + -- after + ~~~~ + + might be + + ~~~~ + sequence [comment "-- before", text "foo", comment "-- after"] + ~~~~ + + but instead we use + + ~~~~ + BDAnnotationsPrior annkey1 -- yields "-- before" + BDAnnotationsRest annkey1 -- yields "-- after" + BDLit "foo" + ~~~~ + + which may seem unnecessarily nested. But this representation has certain + advantages, most importantly rewriting/restructuring the tree is + straigh-forward: consider how `BDAnnotationsPrior annkey (BDSeq [a, b])` can + be transformed into `BDSeq [BDAnnotationsPrior annkey a, b]`. You can do the + same transformation using the "flat" representation, but there are way more + cases to consider. + +## DeltaPosition semantics + +DeltaPositions (we'll just say `DP` which matches the constructor name for this +type) are used to specify where to place comments and regular syntax (including +keywords). This covers both newlines and indentation, and for indentation +includes the case where indentation is mandatory ("layouting rule"). + +Let us look at this example, which was constructed so that each comment +contains its own DP: + +~~~~.hs +do -- DP (0, 1) + + -- DP (2, 2) two newlines, two spaces indentation + abc + -- DB (1, 0) one newline, zero indentation relative to the do-indentation + def +~~~~ + +The first comment is of the easy sort, because it occurs at the end of a +non-empty line: There is no row offset, and the column offset matches the +number of spaces (before the "--") after the last thing in the line. + +The second comment _does_ have a row offset: After the last comment, we have +to insert two line-breaks, then apply the indentation (two spaces) and then +insert the comment starting with "--". This is straight-forward so far. + +The third comment however highlights how DPs are affected by the layouting +rule. + +### Caveat One: Indentation relative to layouting rule indentation level + +Following the first two cases, one would assume that the DP would be +`(1, 2)`. However, for cases where the layouting rule applies +(`do`, `let`, `where`) the indentation of the comments is expressed relative +to the _current indentation_ according to the layouting rule. Unfortunately, +this _current indentation_ is not known until the first construct after +the let, so in the above example, the comment between the `do` and the first +construct (`abc`) has an indentation relative to the enclosing indentation +level (which is 0 for this example). This applies _even_ if the comment is +connected to the first construct (if the first comment is a "prior" comment +of the "abc" syntax node). + +This applies not only to comments, but also to the DPs of all syntax nodes +(including keywords). + +This also means that it is possible to have negative indentation. Consider +this comment: + +~~~~.hs +do + abc + -- fancy comment + def +~~~~ + +### Caveat Two: Caveat one applies to more than the layouting rule + +There are syntactic constructs, for example data declarations, where the +layouting rule does not apply, but for the purpose of `DP` indentations +`ghc-exactprint` pretends that it does. For example: + +~~~~.hs +data Foo = Foo + { myInt :: Int + -- DP (1, -7) relative to the `Foo` constructor (!) + } +~~~~ + +The layouting rule does _not apply in any way_ here. Still, we get a rather +unexpected DP. + +### DeltaPositions of keywords and syntax nodes + +We have mostly talked about comments, but DPs exist and work for keywords +and syntax nodes just like they do for comments. + +~~~~.hs +func = x + + where + + x = 42 +~~~~ + +here, the `where` keyword has a DP of `(2, 1)` and the `x = 42` equation +has a DP of `(2, 2)`. We make use of these DPs using the `BDMoveToKWDP` or the +`BDAnnotationPrior` constructors of the `BriDoc` document. The former would be +used for the `where` keyword, the latter would be applied to the equation +document. diff --git a/doc/implementation/index.md b/doc/implementation/index.md index f6adfad..5e22d2a 100644 --- a/doc/implementation/index.md +++ b/doc/implementation/index.md @@ -18,6 +18,11 @@ Specifying the semantics of the different (smart) constructors of the `BriDoc` type. +- [exactprinting](exactprinting.md) + + A closer look at how we achieve exactprinting, i.e. keeping comments and + certain whitespace (empty lines) as they appear in the input source code. + - Brittany uses the following (randomly deemed noteworthy) libraries: - [`ghc-exactprint`](https://hackage.haskell.org/package/ghc-exactprint) diff --git a/doc/implementation/theory.md b/doc/implementation/theory.md index 50f07ff..df88366 100644 --- a/doc/implementation/theory.md +++ b/doc/implementation/theory.md @@ -18,7 +18,7 @@ will first consider Every haskell module can be written in a single line - of course, in most cases, an unwieldly long one. We humans prefer our lines limitted to some -laughingly small limit like 80 or 160 or whatever. Further, we generally +laughingly small limit like 80 or 160. Further, we generally prefer the indentation of our expressions(, statements etc.) line up with its syntactic structure. This preferences (and the layouting rule which already enforces it partially) still leaves a good amount of choice for @@ -39,8 +39,9 @@ myList = ~~~~ While consistency has the first priority, we also prefer short code: If it -fits, we prefer the version/layout with less lines of code. So we wish to trade -more lines for less columns, but only until things fit. +fits, we prefer the version/layout with less lines of code. So coming from the +everything-in-one-line version, we wish to trade more lines to achieve less +columns, but stop immediately when everything fits into 80 columns. For simple cases we can give a trivial rule: If there is space for the one-line layout, use it; otherwise use the indented-multiline @@ -108,15 +109,19 @@ not help at all in pruning the alternatives on a given layer. In the above `nestedCaseExpr` example, we might obtain a better solution by looking not at just the first, but the first n possible layouts, but against an exponential search-space, this does not scale: Just consider the possibility that there -are exponentially many sub-solutions for layout 2) (replace "good" with some -slightly more complex expression). You basically always end up with either +are exponentially many sub-solutions for layout 2) (replace the literal "good" +in the above example with some slightly more complex expression). +You basically always end up with either "the current line is not yet full, try to fill it up" or "more than n columns used, abort". But a (pure) bottom-up approach does not work either: If we have no clue about the "current" indentation while layouting some node of our syntax tree, information about the (potential) size of (the layout of) child-nodes does -not allow us to make good decisions. +not allow us to make good decisions - if we have a choice between a layout +that takes 40 and a layout that takes 60 columns, we _need_ to know whether +the current indentation is bigger or smaller than 20, otherwise our result +will be non-optimal in general. So we need information to flow bottom-to-top to allow for pruning whole trees of possible layouts, and top-to-bottom for making the actual decisions.. well, @@ -140,6 +145,11 @@ if func x -- => 3 lines, 13 columns used ~~~~ +So internally, to the syntax node of this if-then-else expression we connect +a label containing these two choices, and including the spacing information: +`[(1, 32, someDoc1), (3, 13, someDoc2)]`. where the `someDoc`s are document +representations that can reproduce the above two source code layouts. + This is heavily simplified; in Brittany spacing information is (as usual) a bit more complex. @@ -147,7 +157,8 @@ We restrict the size of these sets. Given the sets of spacings for the child-nodes in the syntax-tree, we generate a limited number of possible spacings in the current node. We then prune nodes that already violate desired properties, e.g. any spacing that already uses more columns locally than -globally available. +globally available - we would not have something like `(_, 90, _)` in the +above list when our limit is 80 columns. The second pass is top-down and uses the spacing-information to decide on one of the possible layouts for the current node. It passes the current -- 2.30.2 From 77d6d5b553720102f05b3977f89566f2c5c1960b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Nov 2019 22:21:16 +0100 Subject: [PATCH 277/478] Fix roundtripping of (~) constraint/type --- src-literatetests/15-regressions.blt | 6 +++++ .../Brittany/Internal/LayouterBasics.hs | 23 ++++++++++++------- .../Brittany/Internal/Layouters/Type.hs | 4 ++-- 3 files changed, 23 insertions(+), 10 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 761dfb5..8942d3f 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -684,3 +684,9 @@ d = \(~x) -> x #test type signature with forall and constraint {-# LANGUAGE RankNTypes #-} func :: forall b . Show b => b -> String + +#test issue 267 + +{-# LANGUAGE TypeFamilies #-} +f :: ((~) a b) => a -> b +f = id diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 701339c..cd5764d 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -206,13 +206,14 @@ rdrNameToText (Exact name) = Text.pack $ getOccString name lrdrNameToText :: GenLocated l RdrName -> Text lrdrNameToText (L _ n) = rdrNameToText n -lrdrNameToTextAnn +lrdrNameToTextAnnGen :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName + => (Text -> Text) + -> Located RdrName -> m Text -lrdrNameToTextAnn ast@(L _ n) = do +lrdrNameToTextAnnGen f ast@(L _ n) = do anns <- mAsk - let t = rdrNameToText n + let t = f $ rdrNameToText n let hasUni x (ExactPrint.Types.G y, _) = x == y hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. @@ -228,15 +229,21 @@ lrdrNameToTextAnn ast@(L _ n) = do _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" _ | otherwise -> t +lrdrNameToTextAnn + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => Located RdrName + -> m Text +lrdrNameToTextAnn = lrdrNameToTextAnnGen id + lrdrNameToTextAnnTypeEqualityIsSpecial :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) => Located RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - x <- lrdrNameToTextAnn ast - return $ if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + let f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + lrdrNameToTextAnnGen f ast -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects -- the annotations for a (parent) node for a tick to be added to the diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index cf9d10c..4902a08 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -40,7 +40,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of #else /* ghc-8.2 ghc-8.4 */ HsTyVar promoted name -> do #endif - t <- lrdrNameToTextAnn name + t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of #if MIN_VERSION_ghc(8,8,0) IsPromoted -> docSeq @@ -54,7 +54,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of NotPromoted -> docWrapNode name $ docLit t #else /* ghc-8.0 */ HsTyVar name -> do - t <- lrdrNameToTextAnn name + t <- lrdrNameToTextAnnTypeEqualityIsSpecial name docWrapNode name $ docLit t #endif #if MIN_VERSION_ghc(8,6,0) -- 2.30.2 From f87c0c64b87ed4b1deb4236aeb7b6d9647bd88d3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 4 Dec 2019 13:36:33 +0100 Subject: [PATCH 278/478] Implement experimental semicolon-into-newlines feature --- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/Backend.hs | 44 +++++++++++-------- .../Haskell/Brittany/Internal/Config.hs | 2 + .../Haskell/Brittany/Internal/Config/Types.hs | 15 +++++++ 5 files changed, 45 insertions(+), 18 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index ef70e44..435e328 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -179,6 +179,7 @@ defaultTestConfig = Config , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_experimentalSemicolonNewlines = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index bf7a1a3..d9555cc 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -60,6 +60,7 @@ defaultTestConfig = Config , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_experimentalSemicolonNewlines = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index e4872f2..8fd7c5d 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -225,26 +225,34 @@ layoutBriDocM = \case -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd - mComments <- do + annMay <- do state <- mGet - let m = _lstate_comments state - let mComments = nonEmpty =<< extractAllComments <$> Map.lookup annKey m - mSet $ state - { _lstate_comments = Map.adjust - ( \ann -> ann { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = - flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } - ) - annKey - m - } - return mComments + let m = _lstate_comments state + pure $ Map.lookup annKey m + let mComments = nonEmpty =<< extractAllComments <$> annMay + let semiCount = length [ () + | Just ann <- [ annMay ] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- mAsk <&> + _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack + mModify $ \state -> state + { _lstate_comments = Map.adjust + ( \ann -> ann { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = + flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } + ) + annKey + (_lstate_comments state) + } case mComments of - Nothing -> pure () + Nothing -> do + when shouldAddSemicolonNewlines $ do + [1..semiCount] `forM_` \_ -> layoutWriteNewline Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 89d125e..5d220fd 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -76,6 +76,7 @@ staticDefaultConfig = Config , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_experimentalSemicolonNewlines = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -179,6 +180,7 @@ cmdlineConfigParser = do , _lconfig_reformatModulePreamble = mempty , _lconfig_allowSingleLineExportList = mempty , _lconfig_allowHangingQuasiQuotes = mempty + , _lconfig_experimentalSemicolonNewlines = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index a415a08..29711c5 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -127,6 +127,21 @@ data CLayoutConfig f = LayoutConfig -- > let body = [json| -- > hello -- > |] + , _lconfig_experimentalSemicolonNewlines :: f (Last Bool) + -- enables an experimental feature to turn semicolons in brace notation + -- into newlines when using layout: + -- + -- > do { a ;; b } + -- + -- turns into + -- > do + -- > a + -- > + -- > b + -- + -- The implementation for this is a bit hacky and not tested; it might + -- break output syntax or not work properly for every kind of brace. So + -- far I have considered `do` and `case-of`. } deriving (Generic) -- 2.30.2 From e24271318d4bdbd16c2bb9cbdacc63c66575395c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Dec 2019 14:30:50 +0100 Subject: [PATCH 279/478] Improve record-expression layouting - Finish consolidation, clearing a TODO - Fix two comment placement issues around record wildcards - Fix regression in brittany-0.12 about layouting large (multiline) record field updates --- src-literatetests/15-regressions.blt | 84 ++++++++++- .../Brittany/Internal/Layouters/Expr.hs | 138 +++++++----------- 2 files changed, 138 insertions(+), 84 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 8942d3f..07cc3a9 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -366,8 +366,23 @@ runBrittany tabSize text = do let config' = staticDefaultConfig config = config' - { _conf_layout = - (_conf_layout config') { _lconfig_indentAmount = coerce tabSize } + { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce + tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text + +#test recordupd-singleline-bug-left + +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +runBrittany tabSize text = do + let + config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } , _conf_forward = forwardOptionsSyntaxExtsEnabled } parsePrintModule config text @@ -690,3 +705,68 @@ func :: forall b . Show b => b -> String {-# LANGUAGE TypeFamilies #-} f :: ((~) a b) => a -> b f = id + +#test large record update +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +vakjkeSulxudbFokvir = Duotpo + { _ekku_gcrpbze = xgonae (1 :: Int) + , _oola_louwu = FoqsiYcuidx + { _xxagu_umea_iaztoj = xgonae False + , _tuktg_tizo_kfikacygsqf = xgonae False + , _ahzbo_xpow_otq_nzeyufq = xgonae False + , _uagpi_lzps_luy_xcjn = xgonae False + , _dxono_qjef_aqtafq_bes = xgonae False + , _yzuaf_nviy_vuhwxe_ihnbo_uhw = xgonae False + , _iwcit_fzjs_yerakt_dicox_mtryitko = xgonae False + , _ehjim_ucfe_dewarp_newrt_gso = xgonae False + , _ogtxb_ivoj_amqgai_rttui_xuwhetb = xgonae False + , _bhycb_iexz_megaug_qunoa_ohaked = xgonae False + , _nnmbe_uqgt_ewsuga_vaiis = xgonae False + , _otzil_ucvugaiyj_aosoiatunx_asir = xgonae False + } + , _iwsc_lalojz = XqspaiDainqw + { _uajznac_ugah = xgonae (80 :: Int) + , _qayziku_gazibzDejipj = xgonae DewizeCxwgyiKjig + , _auhebll_fiqjxyArfxia = xgonae (2 :: Int) + , _zubfuhq_dupiwnIoophXameeet = xgonae True + , _oavnuqg_opkreyOufuIkifiin = xgonae True + , _ufojfwy_fhuzcePeqwfu = xgonae (50 :: Int) + , _mlosikq_zajdxxSeRoelpf = xgonae (50 :: Int) + , _heemavf_fjgOfoaikh = xgonae (FyoVfvdygaZuzuvbeWarwuq 3) + , _ohxmeoq_ogtbfoPtqezVseu = xgonae (EdjotoLcbapUdiuMmytwoig 0.7) + , _omupuiu_ituamexjuLccwu = xgonae (30 :: Int) + , _xoseksf_atvwwdwaoHanofMyUvujjopoz = xgonae True + , _umuuuat_nuamezwWeqfUqzrnaxwp = xgonae False + , _uuriguz_wixhutbuKecigaFiwosret = xgonae True + , _betohxp_scixaLsvcesErtwItxrnaJmuz = xgonae False + , _lchxgee_olaetGcqzuqxVujenCzexub = xgonae True + , _egeibao_imamkuigqikhZdcbpidokVcixiqew = xgonae False + } + , _nloo_cfmrgZcisiugk = YuwodSavxwnicBekuel + { _oebew_rrtpvthUzlizjAqIwesly = xgonae False + , _blkff_Acxoid = xgonae False + , _datei_YewolAowoqOpunvpgu = xgonae BeekgUzojaPnixxaruJehyPmnnfu + , _ejfrj_eheb_justvh_pumcp_ismya = xgonae False + } + , _kena_uzeddovosoki = NyoRvshullezUpauud + { _mtfuwi_TUVEmoi = xgonae RZXKoytUtogx + , _larqam_adaxPehaylZafeqgpc = xgonae False + } + , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } + , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False + , _qaqb_eykzuyuwi = xgonae False + -- test comment + } + +#test large record wildcard comment + +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +vakjkeSulxudbFokvir = Duotpo + { _ekku_gcrpbze = xgonae (1 :: Int) + , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } + , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False + , _qaqb_eykzuyuwi = xgonae False + -- test comment + , -- N.B. + .. -- x + } diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 60be59f..df5ee2a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -974,12 +974,11 @@ layoutExpr lexpr@(L _ expr) = do then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression indentPolicy lexpr nameDoc rFs + recordExpression False indentPolicy lexpr nameDoc rFs HsRecFields [] (Just 0) -> do let t = lrdrNameToText lname docWrapNode lname $ docLit $ t <> Text.pack " { .. }" HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do - -- TODO this should be consolidated into `recordExpression` let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -991,54 +990,7 @@ layoutExpr lexpr@(L _ expr) = do then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - let ((fd1l, fd1n, fd1e):fdr) = fieldDocs - let line1 wrapper = - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior fd1l $ appSep $ docLit fd1n - , case fd1e of - Just x -> docSeq - [ appSep $ docLit $ Text.pack "=" - , docWrapNodeRest fd1l $ wrapper x - ] - Nothing -> docEmpty - ] - let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docWrapNode lfield $ docSeq - [ appSep $ docLit $ Text.pack "=" - , wrapper x - ] - Nothing -> docEmpty - ] - let lineDot = - [ docCommaSep - , docLit $ Text.pack ".." - ] - let lineN = - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free - [ docSeq - $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] - ++ line1 docForceSingleline - ++ join (lineR docForceSingleline) - ++ lineDot - ++ [docSeparator] - ++ lineN - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - ( docNonBottomSpacing - $ docLines - $ [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)] - ++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular)) - ++ [docSeq lineDot, docSeq lineN] - ) - ] + recordExpression True indentPolicy lexpr nameDoc fieldDocs _ -> unknownNodeError "RecordCon with puns" lexpr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecordUpd _ rExpr fields -> do @@ -1061,7 +1013,7 @@ layoutExpr lexpr@(L _ expr) = do Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) #endif - recordExpression indentPolicy lexpr rExprDoc rFs + recordExpression False indentPolicy lexpr rExprDoc rFs #if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */ ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) -> error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" @@ -1225,24 +1177,32 @@ layoutExpr lexpr@(L _ expr) = do recordExpression :: (Data.Data.Data lExpr, Data.Data.Data name) - => IndentPolicy + => Bool + -> IndentPolicy -> GenLocated SrcSpan lExpr -> ToBriDocM BriDocNumbered -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] -> ToBriDocM BriDocNumbered -recordExpression _ lexpr nameDoc [] = +recordExpression False _ lexpr nameDoc [] = docSeq [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] , docLit $ Text.pack "}" ] -recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = +recordExpression True _ lexpr nameDoc [] = + docSeq -- this case might still be incomplete, and is probably not used + -- atm anyway. + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do + let (rF1f, rF1n, rF1e) = rF1 runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } addAlternative $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc , appSep $ docLit $ Text.pack "{" - , appSep $ docSeq $ List.intersperse docCommaSep + , docSeq $ List.intersperse docCommaSep $ rFs <&> \case (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq @@ -1252,6 +1212,9 @@ recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = ] (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr + , if dotdot + then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator , docLit $ Text.pack "}" ] -- hanging single-line fields @@ -1281,11 +1244,15 @@ recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = ] Nothing -> docEmpty ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] + dotdotLine = if dotdot + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] ] -- non-hanging with expressions placed to the right of the names -- container @@ -1299,21 +1266,20 @@ recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = $ docPar (docNodeAnnKW lexpr Nothing nameDoc) (docNonBottomSpacing $ docLines $ let - expressionWrapper = case indentPolicy of - IndentPolicyLeft -> docForceParSpacing - IndentPolicyMultiple -> docForceParSpacing - IndentPolicyFree -> docSetBaseY line1 = docCols ColRec [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit rF1n , docWrapNodeRest rF1f $ case rF1e of - Just x -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x Nothing -> docEmpty ] lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield @@ -1321,20 +1287,28 @@ recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) = [ docCommaSep , appSep $ docLit fText , case fDoc of - Just x -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq [ appSep $ docLit $ Text.pack "=" + , docForceParSpacing x ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x Nothing -> docEmpty ] - lineN = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - , docLit $ Text.pack "}" - ] - in [line1] ++ lineR ++ [lineN] + dotdotLine = if dotdot + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] ) #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ -- 2.30.2 From f8892d41d4485597eac63fe3b8438621c87ce6a4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 9 Dec 2019 13:38:26 +0100 Subject: [PATCH 280/478] Bump to 0.12.1.1; Update changelog --- ChangeLog.md | 12 ++++++++++++ brittany.cabal | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 3230921..2de61e6 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Revision history for brittany +## 0.12.1.1 -- December 2019 + +* Bugfixes: + - Fix layouting regression of record update for many/large fields + - Fix whitespace regression on ExplicitForall notation + (`foo :: forall a . Show a => a -> a`, note the double space) + introduced in 0.12. (#264) + - Fix roundtripping of type equality constraint + `f :: ((~) a b) => a -> b` (#267) +* One experimental feature addition: Turning brace notation semicolons into + newlines when formatting (see #270) + ## 0.12.1.0 -- September 2019 * Support ghc-8.8 diff --git a/brittany.cabal b/brittany.cabal index 3374405..53b1b1b 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.12.1.0 +version: 0.12.1.1 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 172866755cc43b49ad82521b6b2917bf08016173 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 30 Mar 2017 23:23:27 +0200 Subject: [PATCH 281/478] Start impl. layouting for datatypes (#12) Only newtypes work for now; the "interesting" data records are not touched yet. Comment insertion not really considered yet; probably needs work. --- brittany.cabal | 1 + src/Language/Haskell/Brittany/Internal.hs | 8 +- .../Brittany/Internal/Layouters/DataDecl.hs | 134 ++++++++++++++++++ 3 files changed, 140 insertions(+), 3 deletions(-) create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs diff --git a/brittany.cabal b/brittany.cabal index 3374405..9274ad7 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -77,6 +77,7 @@ library { Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Module + Language.Haskell.Brittany.Internal.Layouters.DataDecl Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 9720106..6806f86 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -40,6 +40,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils @@ -51,13 +52,15 @@ import Language.Haskell.Brittany.Internal.Transformations.Par import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC +import qualified GHC as GHC hiding ( parseModule ) import ApiAnnotation ( AnnKeywordId(..) ) -import GHC ( runGhc +import GHC ( Located + , runGhc , GenLocated(L) , moduleNameString ) +import RdrName ( RdrName(..) ) import SrcLoc ( SrcSpan ) import HsSyn import qualified DynFlags as GHC @@ -485,7 +488,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () - getDeclBindingNames :: LHsDecl GhcPs -> [String] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ getDeclBindingNames (L _ decl) = case decl of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs new file mode 100644 index 0000000..0102034 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE KindSignatures #-} + +module Language.Haskell.Brittany.Internal.Layouters.DataDecl + ( layoutDataDecl + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName ( RdrName(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import qualified GHC +import HsSyn +import Name +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import Language.Haskell.Brittany.Internal.Layouters.Type +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Utils + +import Bag ( mapBagM ) + + + +layoutDataDecl + :: Located (HsDecl RdrName) + -> Located RdrName + -> LHsQTyVars RdrName + -> HsDataDefn RdrName + -> ToBriDocM BriDocNumbered +layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) -> + docWrapNode ld $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarDocs <- bndrs `forM` \case + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + tyVarLine <- + fmap return + $ docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLit (Text.pack "(") + , docLit vname + , docSeparator + , kind + , docLit (Text.pack ")") + ] + headDoc <- fmap return $ docSeq + [ appSep $ docLit (Text.pack "newtype") + , appSep $ docLit nameStr + , appSep tyVarLine + ] + rhsDoc <- fmap return $ case details of + PrefixCon args -> docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + RecCon (L _ fields) -> docSeq + [ appSep $ docLit $ Text.pack "{" + , docSeq + $ List.intersperse docSeparator + $ fields + <&> \(L _ (ConDeclField names t _)) -> do + docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \(L _ (FieldOcc fieldName _)) -> + docLit =<< lrdrNameToTextAnn fieldName + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , layoutType t + ] + , docLit $ Text.pack "}" + ] + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + let + mainDoc = + docSeq + [ headDoc + , docSeparator + , docLit (Text.pack "=") + , docSeparator + , rhsDoc + ] + case mDerivs of + Nothing -> mainDoc + Just (L _ [(HsIB _ t)]) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [docLit $ Text.pack "deriving", docSeparator, layoutType t] + Just (L _ ts ) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [ docLit $ Text.pack "deriving" + , docSeparator + , docLit $ Text.pack "(" + , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> + layoutType t + , docLit $ Text.pack ")" + ] + _ -> briDocByExactNoComment ld + + -- HsDataDefn DataType _ctxt _ctype Nothing _conss _derivs -> do + -- -- _ name vars ctxt ctype mKindSig conss derivs + -- nameStr <- lrdrNameToTextAnn name + -- docLit nameStr + + _ -> briDocByExactNoComment ld + -- 2.30.2 From 4f827491daa5dd1ea51a49fbd13ba021d7ad22e2 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 2 May 2017 13:21:18 +0200 Subject: [PATCH 282/478] Work-in-progress commit (deriving clause..) --- src-literatetests/30-tests-context-free.blt | 6 + .../Brittany/Internal/Layouters/DataDecl.hs | 227 ++++++++++++------ 2 files changed, 153 insertions(+), 80 deletions(-) diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index d5c4507..6074d13 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -1163,6 +1163,12 @@ foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do liftIO . forkIO . forever $ getLine >>= inputFire ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent +#test issue 15 +-- Test.hs +module Test where + +data X = X + #test issue 16 foldrDesc f z = unSwitchQueue $ \q -> switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 0102034..8820bda 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -39,96 +39,163 @@ layoutDataDecl -> HsDataDefn RdrName -> ToBriDocM BriDocNumbered layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) -> docWrapNode ld $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName - tyVarDocs <- bndrs `forM` \case - (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - tyVarLine <- - fmap return - $ docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLit (Text.pack "(") - , docLit vname - , docSeparator - , kind - , docLit (Text.pack ")") - ] - headDoc <- fmap return $ docSeq + tyVarLine <- fmap return $ createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLit (Text.pack "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- fmap return $ createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq [ appSep $ docLit (Text.pack "newtype") , appSep $ docLit nameStr , appSep tyVarLine + , docSeparator + , docLit (Text.pack "=") + , docSeparator + , rhsDoc ] - rhsDoc <- fmap return $ case details of - PrefixCon args -> docSeq - [ docLit consNameStr - , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType - ] - RecCon (L _ fields) -> docSeq - [ appSep $ docLit $ Text.pack "{" - , docSeq - $ List.intersperse docSeparator - $ fields - <&> \(L _ (ConDeclField names t _)) -> do - docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \(L _ (FieldOcc fieldName _)) -> - docLit =<< lrdrNameToTextAnn fieldName - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , layoutType t - ] - , docLit $ Text.pack "}" - ] - InfixCon arg1 arg2 -> docSeq - [ layoutType arg1 - , docSeparator - , docLit consNameStr - , docSeparator - , layoutType arg2 - ] - let - mainDoc = - docSeq - [ headDoc - , docSeparator - , docLit (Text.pack "=") - , docSeparator - , rhsDoc - ] - case mDerivs of - Nothing -> mainDoc - Just (L _ [(HsIB _ t)]) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [docLit $ Text.pack "deriving", docSeparator, layoutType t] - Just (L _ ts ) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [ docLit $ Text.pack "deriving" - , docSeparator - , docLit $ Text.pack "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> - layoutType t - , docLit $ Text.pack ")" - ] - _ -> briDocByExactNoComment ld + _ -> briDocByExact ld - -- HsDataDefn DataType _ctxt _ctype Nothing _conss _derivs -> do - -- -- _ name vars ctxt ctype mKindSig conss derivs - -- nameStr <- lrdrNameToTextAnn name - -- docLit nameStr + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> + docWrapNode ld $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + tyVarLine <- fmap return $ createBndrDoc bndrs + createDerivingPar mDerivs $ docSeq + [ appSep $ docLit (Text.pack "data") + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + ] + + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 consName mForall mRhsContext details _)) -> + docWrapNode ld $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- fmap return $ createBndrDoc bndrs + forallDoc <- docSharedWrapper createForallDoc mForall + rhsContextDoc <- case mRhsContext of + Nothing -> return docEmpty + Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt + rhsDoc <- fmap return $ createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLit (Text.pack "data") + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLit (Text.pack "=") + , docSeparator + , forallDoc + , rhsContextDoc + , rhsDoc + ] + _ -> briDocByExact ld _ -> briDocByExactNoComment ld + where + createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered + createContextDoc [] = docEmpty + createContextDoc [t] = + docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] + createContextDoc ts = docSeq + [ docLit (Text.pack "(") + , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) + , docLit (Text.pack ") =>") + , docSeparator + ] + createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered + createBndrDoc bs = do + tyVarDocs <- bs `forM` \case + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLit (Text.pack "(") + , docLit vname + , docSeparator + , docLit (Text.pack "::") + , docSeparator + , kind + , docLit (Text.pack ")") + ] + createDerivingPar + :: HsDeriving RdrName + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + createDerivingPar mDerivs mainDoc = do + case mDerivs of + Nothing -> docLines [mainDoc] + Just (L _ [(HsIB _ t)]) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [docLit $ Text.pack "deriving", docSeparator, layoutType t] + Just (L _ ts ) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [ docLit $ Text.pack "deriving" + , docSeparator + , docLit $ Text.pack "(" + , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> + layoutType t + , docLit $ Text.pack ")" + ] + createDetailsDoc + :: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered) + createDetailsDoc consNameStr details = case details of + PrefixCon args -> docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + RecCon (L _ fields) -> docSeq + [ appSep $ docLit $ Text.pack "{" + , docSeq + $ List.intersperse docSeparator + $ fields + <&> \(L _ (ConDeclField names t _)) -> do + docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \(L _ (FieldOcc fieldName _)) -> + docLit =<< lrdrNameToTextAnn fieldName + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , layoutType t + ] + , docLit $ Text.pack "}" + ] + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered + createForallDoc Nothing = docEmpty + createForallDoc (Just (HsQTvs _ bs _)) = do + tDoc <- fmap return $ createBndrDoc bs + docSeq + [ docLit (Text.pack "forall ") + , tDoc + , docLit (Text.pack " .") + , docSeparator + ] -- 2.30.2 From 57ba88a73c389766bf63983b71f159c7a8ee43a2 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sat, 30 Dec 2017 21:28:01 -0500 Subject: [PATCH 283/478] Work-in-progress add record declaration layout Simple records are supports. The tests cover: - single records - multi-field types - columnized alignment - basic deriving - deriving strategies - existential quanitification A few items block merger - retaining comments A few items can be deferred: - normal types - sum types --- src-literatetests/10-tests.blt | 70 +++++ src-literatetests/30-tests-context-free.blt | 41 +++ src/Language/Haskell/Brittany/Internal.hs | 1 - .../Haskell/Brittany/Internal/Backend.hs | 2 + .../Brittany/Internal/Layouters/DataDecl.hs | 278 +++++++++++------- .../Brittany/Internal/Layouters/Decl.hs | 5 +- .../Haskell/Brittany/Internal/Types.hs | 2 + .../Haskell/Brittany/Internal/Utils.hs | 6 + 8 files changed, 292 insertions(+), 113 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1b152f5..59ffedb 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -310,6 +310,76 @@ func = f f = id +############################################################################### +############################################################################### +############################################################################### +#group data type declarations +############################################################################### +############################################################################### +############################################################################### + +#test single record +data Foo = Bar { foo :: Baz } + +#test record multiple names +data Foo = Bar { foo, bar :: Baz } + +#test record multiple types +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + +#test record multiple types and names +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } + +#test record multiple types deriving +data Foo = Bar + { fooz :: Baz + , bar :: Bizzz + } + deriving Show + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + +#test record multiple deriving strategies +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving Show + deriving (Eq, Ord) + deriving stock Show + deriving stock (Eq, Ord) + deriving anyclass Show + deriving anyclass (Show, Eq, Monad, Functor) + deriving newtype Show + deriving newtype (Traversable, Foldable) + deriving ToJSON via (SomeType) + deriving (ToJSON, FromJSON) via (SomeType) + +#test single record existential +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a . Show a => Bar { foo :: a } + +#test record multiple types existential +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a b . (Show a, Eq b) => Bar + { foo :: a + , bars :: b + } + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 6074d13..9a09fde 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -312,6 +312,47 @@ func = f f = id +############################################################################### +############################################################################### +############################################################################### +#group data type declarations +############################################################################### +############################################################################### +############################################################################### + +#test single record +data Foo = Bar { foo :: Baz } + +#test record multiple names +data Foo = Bar { foo, bar :: Baz } + +#test record multiple types +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + +#test record multiple types and names +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving Show + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 6806f86..b0680a7 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -40,7 +40,6 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 8fd7c5d..32c5aba 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -551,6 +551,8 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do (BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False (BDCols ColApp{} _) -> True diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 8820bda..bfbb025 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -16,7 +16,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString, DerivStrategy(..) ) import qualified GHC import HsSyn import Name @@ -33,16 +33,16 @@ import Bag ( mapBagM ) layoutDataDecl - :: Located (HsDecl RdrName) + :: Located (TyClDecl GhcPs) -> Located RdrName - -> LHsQTyVars RdrName - -> HsDataDefn RdrName + -> LHsQTyVars GhcPs + -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered -layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of - - HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) -> - docWrapNode ld $ do +layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext +layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> + docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs @@ -61,10 +61,10 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of , docSeparator , rhsDoc ] - _ -> briDocByExact ld + _ -> briDocByExact ltycl - HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> - docWrapNode ld $ do + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> + docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name tyVarLine <- fmap return $ createBndrDoc bndrs @@ -75,15 +75,15 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of , appSep tyVarLine ] - HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 consName mForall mRhsContext details _)) -> - docWrapNode ld $ do + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> + docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs - forallDoc <- docSharedWrapper createForallDoc mForall + forallDoc <- docSharedWrapper createForallDoc qvars rhsContextDoc <- case mRhsContext of Nothing -> return docEmpty Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt @@ -100,102 +100,158 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of , rhsContextDoc , rhsDoc ] - _ -> briDocByExact ld + _ -> briDocByExact ltycl - _ -> briDocByExactNoComment ld + _ -> briDocByExactNoComment ltycl + +createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered +createContextDoc [] = docEmpty +createContextDoc [t] = + docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] +createContextDoc ts = docSeq + [ docLit (Text.pack "(") + , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) + , docLit (Text.pack ") =>") + , docSeparator + ] + +createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered +createBndrDoc bs = do + tyVarDocs <- bs `forM` \case + (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar _ext lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + (L _ (XTyVarBndr ext)) -> absurdExt ext + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLit (Text.pack "(") + , docLit vname + , docSeparator + , docLit (Text.pack "::") + , docSeparator + , kind + , docLit (Text.pack ")") + ] + +createDerivingPar + :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +createDerivingPar derivs mainDoc = do + case derivs of + (L _ []) -> docLines [mainDoc] + (L _ types) -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ derivingClauseDoc + <$> types + +derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = + if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "") + (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in + docSeq + [ docDeriving + , lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> + layoutType t + , whenMoreThan1Type ")" + , rhsStrategy + ] where - createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered - createContextDoc [] = docEmpty - createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] - createContextDoc ts = docSeq - [ docLit (Text.pack "(") - , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) - , docLit (Text.pack ") =>") + strategyLeftRight = \case + (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) + (L _ (ViaStrategy viaTypes) ) -> + ( docEmpty + , case viaTypes of + HsIB _ext t -> docSeq + [ docLit $ Text.pack " via " + , layoutType t + ] + XHsImplicitBndrs ext -> absurdExt ext + ) + +docDeriving :: ToBriDocM BriDocNumbered +docDeriving = docLit $ Text.pack "deriving" + +createDetailsDoc + :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) +createDetailsDoc consNameStr details = case details of + PrefixCon args -> docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + RecCon (L _ []) -> docEmpty + RecCon (L _ [L _ (ConDeclField _ext names t _)]) -> docSeq + [ docLit consNameStr + , docSeparator + , appSep $ docLit $ Text.pack "{" + , docSeq $ createNamesAndTypeDoc names t + , docSeparator + , docLit $ Text.pack "}" + ] + RecCon (L _ (fstField:fields)) -> + docAddBaseY BrIndentRegular $ docPar + (docLit consNameStr) + (docLines + [ docCols ColRecDecl + $ docLit (Text.pack "{ ") + : let L _ (ConDeclField _ext names t _) = fstField + in createNamesAndTypeDoc names t + , docLines + $ (\(L _ (ConDeclField _ext names t _)) -> + docCols ColRecDecl $ docCommaSep : createNamesAndTypeDoc names t) + <$> fields + , docLit $ Text.pack "}" + ] + ) + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + +createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered +createForallDoc [] = docEmpty +createForallDoc lhsTyVarBndrs = docSeq + [ docLit (Text.pack "forall ") + , createBndrDoc lhsTyVarBndrs + , docLit (Text.pack " .") + , docSeparator + ] + +createNamesAndTypeDoc + :: [GenLocated t (FieldOcc u)] -> Located (HsType GhcPs) -> [ToBriDocM BriDocNumbered] +createNamesAndTypeDoc names t = + [ docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \(L _ (FieldOcc _ fieldName)) -> + docLit =<< lrdrNameToTextAnn fieldName , docSeparator ] - createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered - createBndrDoc bs = do - tyVarDocs <- bs `forM` \case - (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLit (Text.pack "(") - , docLit vname - , docSeparator - , docLit (Text.pack "::") - , docSeparator - , kind - , docLit (Text.pack ")") - ] - createDerivingPar - :: HsDeriving RdrName - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - createDerivingPar mDerivs mainDoc = do - case mDerivs of - Nothing -> docLines [mainDoc] - Just (L _ [(HsIB _ t)]) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [docLit $ Text.pack "deriving", docSeparator, layoutType t] - Just (L _ ts ) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [ docLit $ Text.pack "deriving" - , docSeparator - , docLit $ Text.pack "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> - layoutType t - , docLit $ Text.pack ")" - ] - createDetailsDoc - :: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered) - createDetailsDoc consNameStr details = case details of - PrefixCon args -> docSeq - [ docLit consNameStr - , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType - ] - RecCon (L _ fields) -> docSeq - [ appSep $ docLit $ Text.pack "{" - , docSeq - $ List.intersperse docSeparator - $ fields - <&> \(L _ (ConDeclField names t _)) -> do - docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \(L _ (FieldOcc fieldName _)) -> - docLit =<< lrdrNameToTextAnn fieldName - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , layoutType t - ] - , docLit $ Text.pack "}" - ] - InfixCon arg1 arg2 -> docSeq - [ layoutType arg1 - , docSeparator - , docLit consNameStr - , docSeparator - , layoutType arg2 - ] - createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered - createForallDoc Nothing = docEmpty - createForallDoc (Just (HsQTvs _ bs _)) = do - tDoc <- fmap return $ createBndrDoc bs - docSeq - [ docLit (Text.pack "forall ") - , tDoc - , docLit (Text.pack " .") - , docSeparator - ] - + , docSeq + [ docLit $ Text.pack "::" + , docSeparator + , layoutType t + ] + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 6d9a1f5..7b52383 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -53,6 +53,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Bag ( mapBagM, bagToList, emptyBag ) import Data.Char (isUpper) @@ -85,7 +86,6 @@ layoutDecl d@(L loc decl) = case decl of _ -> briDocByExactNoComment d #endif - -------------------------------------------------------------------------------- -- Sig -------------------------------------------------------------------------------- @@ -741,6 +741,9 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ + DataDecl _ext name tyVars _ dataDefn -> + docWrapNodePrior ltycl $ + layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl layoutSynDecl diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 8aad965..e3a5318 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -185,6 +185,8 @@ data ColSig | ColBindStmt | ColDoLet -- the non-indented variant | ColRec + | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRecDecl | ColListComp | ColList | ColApp Text diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index dfd28c3..ae7bed9 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -25,6 +25,7 @@ module Language.Haskell.Brittany.Internal.Utils , splitFirstLast , lines' , showOutputable + , absurdExt ) where @@ -57,6 +58,7 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate +import HsExtension (NoExt) @@ -293,3 +295,7 @@ lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r + +-- | A method to dismiss NoExt patterns for total matches +absurdExt :: NoExt -> a +absurdExt = error "cannot construct NoExt" -- 2.30.2 From 208a1ceadb0b2b34f3c807b30232db683dd6969a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 11 Oct 2019 00:51:13 +0200 Subject: [PATCH 284/478] Start making datadecls work with ghc-8.4 --- .../Brittany/Internal/Layouters/DataDecl.hs | 85 ++++++++++++++++--- .../Brittany/Internal/Layouters/Decl.hs | 4 + .../Haskell/Brittany/Internal/Utils.hs | 9 +- 3 files changed, 82 insertions(+), 16 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index bfbb025..082a5c4 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -16,10 +16,11 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, DerivStrategy(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import qualified GHC import HsSyn import Name +import BasicTypes import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import Language.Haskell.Brittany.Internal.Layouters.Type @@ -38,10 +39,19 @@ layoutDataDecl -> LHsQTyVars GhcPs -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of +#else +layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> +#else + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _conDoc)) -> +#endif docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName @@ -61,9 +71,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSeparator , rhsDoc ] - _ -> briDocByExact ltycl + _ -> briDocByExactNoComment ltycl +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> +#else + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> +#endif docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name @@ -75,9 +89,17 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , appSep tyVarLine ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> +#else + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> +#endif case cons of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> +#else + (L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) -> +#endif docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name @@ -100,7 +122,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , rhsContextDoc , rhsDoc ] - _ -> briDocByExact ltycl + _ -> briDocByExactNoComment ltycl _ -> briDocByExactNoComment ltycl @@ -118,11 +140,18 @@ createContextDoc ts = docSeq createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do tyVarDocs <- bs `forM` \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) (L _ (KindedTyVar _ext lrdrName kind)) -> do +#else + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do +#endif d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (XTyVarBndr ext)) -> absurdExt ext +#endif docSeq $ List.intersperse docSeparator $ tyVarDocs @@ -151,8 +180,12 @@ createDerivingPar derivs mainDoc = do <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of +#else +derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of +#endif (L _ []) -> docSeq [] (L _ ts) -> let @@ -166,8 +199,13 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of , lhsStrategy , docSeparator , whenMoreThan1Type "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> - layoutType t + , docSeq $ List.intersperse docCommaSep $ ts <&> \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIB _ t -> layoutType t + XHsImplicitBndrs x -> absurdExt x +#else + HsIB _ t _ -> layoutType t +#endif , whenMoreThan1Type ")" , rhsStrategy ] @@ -176,6 +214,7 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of @@ -185,6 +224,7 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of ] XHsImplicitBndrs ext -> absurdExt ext ) +#endif docDeriving :: ToBriDocM BriDocNumbered docDeriving = docLit $ Text.pack "deriving" @@ -198,7 +238,11 @@ createDetailsDoc consNameStr details = case details of , docSeq $ List.intersperse docSeparator $ args <&> layoutType ] RecCon (L _ []) -> docEmpty +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecCon (L _ [L _ (ConDeclField _ext names t _)]) -> docSeq +#else + RecCon (L _ [L _ (ConDeclField names t _)]) -> docSeq +#endif [ docLit consNameStr , docSeparator , appSep $ docLit $ Text.pack "{" @@ -206,18 +250,15 @@ createDetailsDoc consNameStr details = case details of , docSeparator , docLit $ Text.pack "}" ] - RecCon (L _ (fstField:fields)) -> + RecCon (L _ fields@(_:_)) -> do + let (fDoc1 : fDocR) = mkFieldDocs fields docAddBaseY BrIndentRegular $ docPar (docLit consNameStr) (docLines [ docCols ColRecDecl $ docLit (Text.pack "{ ") - : let L _ (ConDeclField _ext names t _) = fstField - in createNamesAndTypeDoc names t - , docLines - $ (\(L _ (ConDeclField _ext names t _)) -> - docCols ColRecDecl $ docCommaSep : createNamesAndTypeDoc names t) - <$> fields + : fDoc1 + , docLines $ fDocR <&> \f -> docCols ColRecDecl $ docCommaSep : f , docLit $ Text.pack "}" ] ) @@ -228,6 +269,14 @@ createDetailsDoc consNameStr details = case details of , docSeparator , layoutType arg2 ] + where + mkFieldDocs = fmap $ \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc names t + L _ (XConDeclField x) -> absurdExt x +#else + L _ (ConDeclField names t _) -> createNamesAndTypeDoc names t +#endif createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createForallDoc [] = docEmpty @@ -239,13 +288,21 @@ createForallDoc lhsTyVarBndrs = docSeq ] createNamesAndTypeDoc - :: [GenLocated t (FieldOcc u)] -> Located (HsType GhcPs) -> [ToBriDocM BriDocNumbered] + :: [GenLocated t (FieldOcc GhcPs)] + -> Located (HsType GhcPs) + -> [ToBriDocM BriDocNumbered] createNamesAndTypeDoc names t = [ docSeq [ docSeq $ List.intersperse docCommaSep $ names - <&> \(L _ (FieldOcc _ fieldName)) -> + <&> \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (XFieldOcc x) -> absurdExt x + L _ (FieldOcc _ fieldName) -> +#else + L _ (FieldOcc fieldName _) -> +#endif docLit =<< lrdrNameToTextAnn fieldName , docSeparator ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 7b52383..153774f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -741,7 +741,11 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ +#if MIN_VERSION_ghc(8,6,0) DataDecl _ext name tyVars _ dataDefn -> +#else + DataDecl name tyVars _ dataDefn _ _ -> +#endif docWrapNodePrior ltycl $ layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index ae7bed9..eee432e 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -58,7 +58,7 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate -import HsExtension (NoExt) +import qualified HsExtension @@ -296,6 +296,11 @@ lines' s = case break (== '\n') s of (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ -- | A method to dismiss NoExt patterns for total matches -absurdExt :: NoExt -> a +absurdExt :: HsExtension.NoExt -> a absurdExt = error "cannot construct NoExt" +#else +absurdExt :: () +absurdExt = () +#endif -- 2.30.2 From d21ecf89e6c31f34f58f7da514e56d6b8167ef8d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 23 Oct 2019 01:32:01 +0200 Subject: [PATCH 285/478] Fix a comment bug in tuple-type layouting --- src-literatetests/10-tests.blt | 8 +++++ .../Brittany/Internal/LayouterBasics.hs | 35 +++++++++++++------ .../Brittany/Internal/Layouters/Type.hs | 15 ++++---- 3 files changed, 42 insertions(+), 16 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 59ffedb..78de0ce 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1163,6 +1163,14 @@ type (a :+: b) = (a, b) type ((a :+: b) c) = (a, c) +#test synonym-tuple-type-many-comments + +type Foo + = ( -- t1 + A -- t2 + , -- t3 + B -- t4 + ) -- t5 ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index cd5764d..d7acf16 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -642,18 +642,18 @@ docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a docWrapNodePrior :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a docWrapNodeRest :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a -instance DocWrapable BriDocNumbered where +instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNode ast bdm = do bd <- bdm i1 <- allocNodeIndex @@ -679,7 +679,22 @@ instance DocWrapable BriDocNumbered where $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd -instance DocWrapable a => DocWrapable [a] where +instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where + docWrapNode ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNode ast bd] + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> + [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] + _ -> error "cannot happen (TM)" + docWrapNodePrior ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNodePrior ast bd] + (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR + docWrapNodeRest ast bdms = case reverse bdms of + [] -> [] + (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do bds <- bdsm case bds of @@ -707,7 +722,7 @@ instance DocWrapable a => DocWrapable [a] where bdN' <- docWrapNodeRest ast (return bdN) return $ reverse (bdN':bdR) -instance DocWrapable a => DocWrapable (Seq a) where +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do bds <- bdsm case Seq.viewl bds of @@ -735,7 +750,7 @@ instance DocWrapable a => DocWrapable (Seq a) where bdN' <- docWrapNodeRest ast (return bdN) return $ bdR Seq.|> bdN' -instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where +instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where docWrapNode ast stuffM = do (bds, bd, x) <- stuffM if null bds diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 4902a08..bf5a956 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -444,15 +444,17 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of docs <- docSharedWrapper layoutType `mapM` typs let end = docLit $ Text.pack ")" lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt [ docSeq $ [docLit $ Text.pack "("] - ++ List.intersperse docCommaSep (docForceSingleline <$> docs) + ++ docWrapNodeRest ltype commaDocs ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] in docPar (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs @@ -460,15 +462,16 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of end = docParenHashRSep docAlt [ docSeq $ [start] - ++ List.intersperse docCommaSep docs + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) - (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + (docLines $ lines ++ [end]) ] HsOpTy{} -> -- TODO briDocByExactInlineOnly "HsOpTy{}" ltype -- 2.30.2 From 2f6967b7b8fcb47d5e9ea09efaf7c93860da87dc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 23 Oct 2019 01:43:23 +0200 Subject: [PATCH 286/478] Support comments in record data decls --- src-literatetests/10-tests.blt | 40 ++++++++++++++++ .../Brittany/Internal/Layouters/DataDecl.hs | 48 +++++++++++-------- 2 files changed, 69 insertions(+), 19 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 78de0ce..d12ba21 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -379,6 +379,46 @@ data Foo = forall a b . (Show a, Eq b) => Bar , bars :: b } +#test record comments simple +data Foo = Bar -- a + { foo :: Baz -- b + , bars :: Bizzz -- c + } -- d + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e + +#test record comments strange inline +data Foo = Bar + { -- a + foo -- b + :: -- c + Baz -- d + , -- e + bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + +#test record comments in deriving +## maybe we want to switch to a differnt layout when there are such comments. +## Don't hesitate to modify this testcase, it clearly is not the ideal layout +## for this. + +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --b + ( -- c + ToJSON -- d + , -- e + FromJSON --f + ) -- g + via -- h + ( -- i + SomeType --j + , -- k + ABC --l + ) ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 082a5c4..fed333e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -176,6 +176,7 @@ createDerivingPar derivs mainDoc = do docPar mainDoc $ docEnsureIndent BrIndentRegular $ docLines + $ docWrapNode derivs $ derivingClauseDoc <$> types @@ -196,10 +197,13 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of in docSeq [ docDeriving - , lhsStrategy + , docWrapNodePrior types $ lhsStrategy , docSeparator , whenMoreThan1Type "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \case + , docWrapNodeRest types + $ docSeq + $ List.intersperse docCommaSep + $ ts <&> \case #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIB _ t -> layoutType t XHsImplicitBndrs x -> absurdExt x @@ -215,11 +219,12 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - (L _ (ViaStrategy viaTypes) ) -> + lVia@(L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of HsIB _ext t -> docSeq - [ docLit $ Text.pack " via " + [ docWrapNode lVia $ docLit $ Text.pack " via" + , docSeparator , layoutType t ] XHsImplicitBndrs ext -> absurdExt ext @@ -239,26 +244,28 @@ createDetailsDoc consNameStr details = case details of ] RecCon (L _ []) -> docEmpty #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecCon (L _ [L _ (ConDeclField _ext names t _)]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> docSeq #else - RecCon (L _ [L _ (ConDeclField names t _)]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> docSeq #endif [ docLit consNameStr , docSeparator - , appSep $ docLit $ Text.pack "{" - , docSeq $ createNamesAndTypeDoc names t + , docWrapNodePrior lRec $ docLit $ Text.pack "{" + , docSeparator + , docWrapNodeRest lRec $ docSeq $ createNamesAndTypeDoc lField names t , docSeparator , docLit $ Text.pack "}" ] - RecCon (L _ fields@(_:_)) -> do + RecCon lRec@(L _ fields@(_:_)) -> do let (fDoc1 : fDocR) = mkFieldDocs fields docAddBaseY BrIndentRegular $ docPar (docLit consNameStr) - (docLines + (docWrapNodePrior lRec $ docLines [ docCols ColRecDecl - $ docLit (Text.pack "{ ") + $ appSep (docLit (Text.pack "{")) : fDoc1 - , docLines $ fDocR <&> \f -> docCols ColRecDecl $ docCommaSep : f + , docWrapNodeRest lRec $ docLines $ fDocR <&> \f -> + docCols ColRecDecl $ docCommaSep : f , docLit $ Text.pack "}" ] ) @@ -270,12 +277,13 @@ createDetailsDoc consNameStr details = case details of , layoutType arg2 ] where - mkFieldDocs = fmap $ \case + mkFieldDocs :: [LConDeclField GhcPs] -> [[ToBriDocM BriDocNumbered]] + mkFieldDocs = fmap $ \lField -> case lField of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc names t + L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (XConDeclField x) -> absurdExt x #else - L _ (ConDeclField names t _) -> createNamesAndTypeDoc names t + L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t #endif createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered @@ -288,11 +296,13 @@ createForallDoc lhsTyVarBndrs = docSeq ] createNamesAndTypeDoc - :: [GenLocated t (FieldOcc GhcPs)] + :: Data.Data.Data ast + => Located ast + -> [GenLocated t (FieldOcc GhcPs)] -> Located (HsType GhcPs) -> [ToBriDocM BriDocNumbered] -createNamesAndTypeDoc names t = - [ docSeq +createNamesAndTypeDoc lField names t = + [ docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq [ docSeq $ List.intersperse docCommaSep $ names @@ -306,7 +316,7 @@ createNamesAndTypeDoc names t = docLit =<< lrdrNameToTextAnn fieldName , docSeparator ] - , docSeq + , docWrapNodeRest lField $ docSeq [ docLit $ Text.pack "::" , docSeparator , layoutType t -- 2.30.2 From 868b8c61e3a79bddb9ab054073e81cd07591bb85 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 19:57:06 -0600 Subject: [PATCH 287/478] Add a Makefile for easy testing many version The `Makefile` includes `stack test` configurations to support building versions of `brittany` with supported versions of `ghc`. Each version uses a separate `.stack-work` directory to allow minimal compilation on each change. --- .gitignore | 3 ++- Makefile | 28 ++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 1 deletion(-) create mode 100644 Makefile diff --git a/.gitignore b/.gitignore index 4393459..4cdb828 100644 --- a/.gitignore +++ b/.gitignore @@ -12,4 +12,5 @@ local/ cabal.sandbox.config cabal.project.local .ghc.environment.* -result \ No newline at end of file +result +.stack-work* diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e0213ab --- /dev/null +++ b/Makefile @@ -0,0 +1,28 @@ +.PHONY: test +test: + echo "test" + stack test + +.PHONY: test-all +test-all: + $(MAKE) test test-8.6.5 test-8.4.3 test-8.2.2 test-8.0.2 + +.PHONY: test-8.6.5 +test-8.6.5: + echo "test 8.6.5" + stack test --stack-yaml stack-8.6.5.yaml --work-dir .stack-work-8.6.5 + +.PHONY: test-8.4.3 +test-8.4.3: + echo "test 8.4.3" + stack test --stack-yaml stack-8.4.3.yaml --work-dir .stack-work-8.4.3 + +.PHONY: test-8.2.2 +test-8.2.2: + echo "test 8.2.2" + stack test --stack-yaml stack-8.2.2.yaml --work-dir .stack-work-8.2.2 + +.PHONY: test-8.0.2 +test-8.0.2: + echo "test 8.0.2" + stack test --stack-yaml stack-8.0.2.yaml --work-dir .stack-work-8.0.2 -- 2.30.2 From dee63517ba7a4468d7c41b99bc5c318d6bd63b84 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 19:59:41 -0600 Subject: [PATCH 288/478] Include stack lock files --- stack-8.2.2.yaml.lock | 33 ++++++++++++++++++++++++++++++ stack-8.4.3.yaml.lock | 19 +++++++++++++++++ stack-8.6.5.yaml.lock | 26 ++++++++++++++++++++++++ stack.yaml.lock | 47 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 125 insertions(+) create mode 100644 stack-8.2.2.yaml.lock create mode 100644 stack-8.4.3.yaml.lock create mode 100644 stack-8.6.5.yaml.lock create mode 100644 stack.yaml.lock diff --git a/stack-8.2.2.yaml.lock b/stack-8.2.2.yaml.lock new file mode 100644 index 0000000..8bacbb2 --- /dev/null +++ b/stack-8.2.2.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: czipwith-1.0.1.0@sha256:30751c5a92488304863f20403cd8e9d4fee2b5def0b656a3d979aa3331a09c00,1652 + pantry-tree: + size: 323 + sha256: acd60968c5a1945741204751243f88d1af1c152018c2d9575f62c0805825f44f + original: + hackage: czipwith-1.0.1.0 +- completed: + hackage: butcher-1.3.1.1@sha256:d5734df2e42c28c5a8419eb8251cc531e5f5e6a13794b2ae1dac04abd1c359ad,3242 + pantry-tree: + size: 1197 + sha256: 057b5c8aa0211951337d87cda1f3d4c6f049945314f6fc7883394eebac79be5b + original: + hackage: butcher-1.3.1.1 +- completed: + hackage: ghc-exactprint-0.5.8.0@sha256:71915a08a7d442d39a63cb3b0fbd90b7dacd19bc4b05bac5c53b6e8a0d931b7b,7728 + pantry-tree: + size: 83871 + sha256: 3998143d33f7de29b31e8cf8d1b207c1fb4962f819fc820e209e1eecbf7e5a35 + original: + hackage: ghc-exactprint-0.5.8.0 +snapshots: +- completed: + size: 505335 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/1.yaml + sha256: 59c853f993e736f430ad20d03eb5441c715d84359c035de906f970841887a8f8 + original: lts-11.1 diff --git a/stack-8.4.3.yaml.lock b/stack-8.4.3.yaml.lock new file mode 100644 index 0000000..b4a4818 --- /dev/null +++ b/stack-8.4.3.yaml.lock @@ -0,0 +1,19 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: ghc-exactprint-0.5.8.1@sha256:f76eed0976b854ce03928796e9cff97769e304618ca99bc0f6cdccab31e539d0,7728 + pantry-tree: + size: 83871 + sha256: 14febc191ef8b0d1f218d13e8db9ed20395f10a5b3d8aa2c0d45869a037420a2 + original: + hackage: ghc-exactprint-0.5.8.1 +snapshots: +- completed: + size: 504336 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/12.yaml + sha256: 11db5c37144d13fe6b56cd511050b4e6ffe988f6edb8e439c2432fc9fcdf50c3 + original: lts-12.12 diff --git a/stack-8.6.5.yaml.lock b/stack-8.6.5.yaml.lock new file mode 100644 index 0000000..a7d341f --- /dev/null +++ b/stack-8.6.5.yaml.lock @@ -0,0 +1,26 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: butcher-1.3.2.1@sha256:cf479ea83a08f4f59a482e7c023c70714e7c93c1ccd7d53fe076ad3f1a3d2b8d,3115 + pantry-tree: + size: 1197 + sha256: dc4bd6adc5f8bd3589533659b62567da78b6956d7098e561c0523c60fcaa0406 + original: + hackage: butcher-1.3.2.1 +- completed: + hackage: multistate-0.8.0.1@sha256:496ac087a0df3984045d7460b981d5e868a49e160b60a6555f6799e81e58542d,3700 + pantry-tree: + size: 2143 + sha256: 0136d5fcddee0244c3bc73b4ae1b489134a1dd12a8978f437b2be81e98f5d8bd + original: + hackage: multistate-0.8.0.1 +snapshots: +- completed: + size: 498398 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/23.yaml + sha256: 63151ca76f39d5cfbd266ce019236459fdda53fbefd2200aedeb33bcc81f808e + original: lts-13.23 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..6b3c445 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,47 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: multistate-0.8.0.2@sha256:fbb0d8ade9ef73c8ed92488f5804d0ebe75d3a9c24bf53452bc3a4f32b34cb2e,3713 + pantry-tree: + size: 2143 + sha256: 1753828d37b456e1e0241766d893b29f385ef7769fa79610f507b747935b77cb + original: + hackage: multistate-0.8.0.2 +- completed: + hackage: butcher-1.3.2.3@sha256:1b8040eddb6da2a05426bf9f6c56b078e629228d64d7d61fb3daa88802487e1b,3262 + pantry-tree: + size: 1197 + sha256: 6bf3a318bd8689bd1fa7a8084c0d96372768d2dc3e30d9aa58d07741ed6816e6 + original: + hackage: butcher-1.3.2.3 +- completed: + hackage: deque-0.4.2.3@sha256:7cc8ddfc77df351ff9c16e838ccdb4a89f055c80a3111e27eba8d90e8edde7d0,1853 + pantry-tree: + size: 807 + sha256: 7f584c71e9e912935f829cb4667411ae3c3048fcd8b935170fb5a45188019403 + original: + hackage: deque-0.4.2.3 +- completed: + hackage: strict-list-0.1.4@sha256:0fa869e2c21b710b7133e8628169f120fe6299342628edd3d5087ded299bc941,1631 + pantry-tree: + size: 340 + sha256: bbb22fd014867dc48697ddd8598d4a9fb03fa2d58ef79bed94f208a9b6d94224 + original: + hackage: strict-list-0.1.4 +- completed: + hackage: ghc-exactprint-0.5.8.2@sha256:b078e02ce263db6214f8418c8b6f6be1c8a7ca1499bb2f8936b91b5ed210faa5,7901 + pantry-tree: + size: 83871 + sha256: 1dc1dc7f036dfb8e7642deaeb2845c62731085abc29a1494c22cd6b1b5a18d16 + original: + hackage: ghc-exactprint-0.5.8.2 +snapshots: +- completed: + size: 499461 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/25.yaml + sha256: aed98969628e20615e96b06083c933c7e3354ae56b08b75e607a26569225d6c0 + original: lts-13.25 -- 2.30.2 From 9971e3905d1c7bb1f54bf117650403fcc9100f73 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 20:08:27 -0600 Subject: [PATCH 289/478] Support building DataDecl with 8.2.2 --- src/Language/Haskell/Brittany/Internal/Utils.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index eee432e..435ad96 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -58,7 +59,9 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate +#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ import qualified HsExtension +#endif -- 2.30.2 From aeaa043e99d4e4469dac782643695c73c3e99d38 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 21:01:03 -0600 Subject: [PATCH 290/478] Support building DataDecl with 8.0.2 --- .../Brittany/Internal/Layouters/DataDecl.hs | 27 +++++++++++++++++-- .../Brittany/Internal/Layouters/Decl.hs | 4 ++- 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index fed333e..c900156 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE KindSignatures #-} @@ -171,6 +172,7 @@ createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered createDerivingPar derivs mainDoc = do case derivs of +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (L _ []) -> docLines [mainDoc] (L _ types) -> docPar mainDoc @@ -179,13 +181,26 @@ createDerivingPar derivs mainDoc = do $ docWrapNode derivs $ derivingClauseDoc <$> types +#else + Nothing -> docLines [mainDoc] + Just types -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ derivingClauseDoc types +#endif +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +#else +derivingClauseDoc :: Located [LHsSigType GhcPs] -> ToBriDocM BriDocNumbered +#endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of -#else +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of +#else +derivingClauseDoc types = case types of #endif (L _ []) -> docSeq [] (L _ ts) -> @@ -193,7 +208,11 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of tsLength = length ts whenMoreThan1Type val = if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "") +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy +#else + (lhsStrategy, rhsStrategy) = (docEmpty, docEmpty) +#endif in docSeq [ docDeriving @@ -207,12 +226,15 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIB _ t -> layoutType t XHsImplicitBndrs x -> absurdExt x -#else +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsIB _ t _ -> layoutType t +#else + HsIB _ t -> layoutType t #endif , whenMoreThan1Type ")" , rhsStrategy ] +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */ where strategyLeftRight = \case (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) @@ -230,6 +252,7 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of XHsImplicitBndrs ext -> absurdExt ext ) #endif +#endif docDeriving :: ToBriDocM BriDocNumbered docDeriving = docLit $ Text.pack "deriving" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 153774f..5f99020 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -743,8 +743,10 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ #if MIN_VERSION_ghc(8,6,0) DataDecl _ext name tyVars _ dataDefn -> -#else +#elif MIN_VERSION_ghc(8,2,0) DataDecl name tyVars _ dataDefn _ _ -> +#else + DataDecl name tyVars dataDefn _ _ -> #endif docWrapNodePrior ltycl $ layoutDataDecl ltycl name tyVars dataDefn -- 2.30.2 From b2f4262749dbc601f2e66901d2575003271ac683 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 21:04:42 -0600 Subject: [PATCH 291/478] Isolate deriving via test --- src-literatetests/10-tests.blt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index d12ba21..3a188de 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -363,6 +363,12 @@ data Foo = Bar deriving anyclass (Show, Eq, Monad, Functor) deriving newtype Show deriving newtype (Traversable, Foldable) + +#test record deriving via +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } deriving ToJSON via (SomeType) deriving (ToJSON, FromJSON) via (SomeType) -- 2.30.2 From ea9d3bb5b3fad544e59d5d08f5d6d872383c2c55 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 21:05:34 -0600 Subject: [PATCH 292/478] Add stack lock file for 8.0.2 --- stack-8.0.2.yaml.lock | 54 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 stack-8.0.2.yaml.lock diff --git a/stack-8.0.2.yaml.lock b/stack-8.0.2.yaml.lock new file mode 100644 index 0000000..08d3ffb --- /dev/null +++ b/stack-8.0.2.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: monad-memo-0.4.1@sha256:d7575b0c89ad21818ca5746170d10a3b92f01fdf9028fa37d3a370e42b24b38b,3672 + pantry-tree: + size: 1823 + sha256: 8d7bcc8a8bce43804613a160fd7f0fea7869a54e530a9f1b9f9e853ec4e00b57 + original: + hackage: monad-memo-0.4.1 +- completed: + hackage: czipwith-1.0.1.0@sha256:30751c5a92488304863f20403cd8e9d4fee2b5def0b656a3d979aa3331a09c00,1652 + pantry-tree: + size: 323 + sha256: acd60968c5a1945741204751243f88d1af1c152018c2d9575f62c0805825f44f + original: + hackage: czipwith-1.0.1.0 +- completed: + hackage: butcher-1.3.1.1@sha256:d5734df2e42c28c5a8419eb8251cc531e5f5e6a13794b2ae1dac04abd1c359ad,3242 + pantry-tree: + size: 1197 + sha256: 057b5c8aa0211951337d87cda1f3d4c6f049945314f6fc7883394eebac79be5b + original: + hackage: butcher-1.3.1.1 +- completed: + hackage: data-tree-print-0.1.0.0@sha256:6610723626501d3ab65dc2290c0de59de8d042caf72a1db1e0cd01e84d229346,1547 + pantry-tree: + size: 272 + sha256: caa741fd498f754b42d45a16aae455056d5e71df51e960fce1579b8e8b6496ad + original: + hackage: data-tree-print-0.1.0.0 +- completed: + hackage: deque-0.2@sha256:a9736298cd04472924b3b681b3791c99e8b6009a6e5df1ff13dd57457109ad43,877 + pantry-tree: + size: 205 + sha256: c48e1f58dfac107ba9dd8d159d4c033fd72521de678204788e3f01f7a2e17546 + original: + hackage: deque-0.2 +- completed: + hackage: ghc-exactprint-0.5.8.0@sha256:71915a08a7d442d39a63cb3b0fbd90b7dacd19bc4b05bac5c53b6e8a0d931b7b,7728 + pantry-tree: + size: 83871 + sha256: 3998143d33f7de29b31e8cf8d1b207c1fb4962f819fc820e209e1eecbf7e5a35 + original: + hackage: ghc-exactprint-0.5.8.0 +snapshots: +- completed: + size: 533451 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/9/0.yaml + sha256: 27f29b231b39ea68e967a7a4346b2693a49d77c50f41fc0c276e11189a538da7 + original: lts-9.0 -- 2.30.2 From 48490a71100eb2b90b83a12c75e30ecd9a9cd2f4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 31 Oct 2019 13:44:52 +0100 Subject: [PATCH 293/478] Fix handling of comment before data-decl `docWrapNodePrior` caused duplication of offset of `data` keyword and of comments connected to it. --- src-literatetests/10-tests.blt | 5 +++++ .../Haskell/Brittany/Internal/Layouters/DataDecl.hs | 6 ++++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 3 +-- 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 3a188de..0217311 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -385,6 +385,11 @@ data Foo = forall a b . (Show a, Eq b) => Bar , bars :: b } +#test plain comment simple +-- before +data MyData = MyData Int +-- after + #test record comments simple data Foo = Bar -- a { foo :: Baz -- b diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index c900156..5dbb8db 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -46,6 +46,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of #else layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of #endif + -- newtype MyType a b = MyType .. #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> @@ -74,6 +75,9 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ] _ -> briDocByExactNoComment ltycl + + -- data MyData a b + -- (zero constructors) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> #else @@ -90,6 +94,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of , appSep tyVarLine ] + -- data MyData = MyData .. + -- data MyData = MyData { .. } #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> #else diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 5f99020..fbbcafd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -748,8 +748,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of #else DataDecl name tyVars dataDefn _ _ -> #endif - docWrapNodePrior ltycl $ - layoutDataDecl ltycl name tyVars dataDefn + layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl layoutSynDecl -- 2.30.2 From 54f34344b3ef523a2909176b4aa499fa774e2b74 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 7 Nov 2019 00:58:38 +0100 Subject: [PATCH 294/478] Implement #min-ghc keyword for test script --- src-literatetests/10-tests.blt | 28 ++++-- src-literatetests/Main.hs | 167 +++++++++++++++++++-------------- 2 files changed, 121 insertions(+), 74 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 0217311..44e82e0 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -365,6 +365,7 @@ data Foo = Bar deriving newtype (Traversable, Foldable) #test record deriving via +#min-ghc 8.6 data Foo = Bar { foo :: Baz , bars :: Bizzz @@ -424,12 +425,27 @@ data Foo = Bar , -- e FromJSON --f ) -- g - via -- h - ( -- i - SomeType --j - , -- k - ABC --l - ) + +#test record comments in deriving via +## maybe we want to switch to a differnt layout when there are such comments. +## Don't hesitate to modify this testcase, it clearly is not the ideal layout +## for this. +#min-ghc 8.6 + +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --a + ToJSON --b + via -- c + ( -- d + SomeType --e + , -- f + ABC --g + ) + ############################################################################### ############################################################################### diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 435e328..93ae27a 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,42 +1,56 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} -module Main (main) where +module Main + ( main + ) +where #include "prelude.inc" -import Test.Hspec -import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs ) +import Test.Hspec +import Test.Hspec.Runner ( hspecWith + , defaultConfig + , configConcurrentJobs + ) -import NeatInterpolation +import NeatInterpolation -import qualified Text.Parsec as Parsec -import Text.Parsec.Text ( Parser ) +import qualified Text.Parsec as Parsec +import Text.Parsec.Text ( Parser ) -import Data.Char ( isSpace ) -import Data.List ( groupBy ) +import Data.Char ( isSpace ) +import Data.List ( groupBy ) -import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config -import Data.Coerce ( coerce ) +import Data.Coerce ( coerce ) -import qualified Data.Text.IO as Text.IO -import System.FilePath ( () ) +import qualified Data.Text.IO as Text.IO +import System.FilePath ( () ) data InputLine = GroupLine Text | HeaderLine Text + | GhcVersionGuardLine Text | PendingLine | NormalLine Text | CommentLine deriving Show +data TestCase = TestCase + { testName :: Text + , isPending :: Bool + , minGHCVersion :: Maybe Text + , content :: Text + } main :: IO () main = do @@ -44,28 +58,39 @@ main = do let blts = List.sort $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt"`isSuffixOf`) files + $ filter (".blt" `isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree + let parseVersion :: Text -> Maybe [Int] + parseVersion = + mapM (readMaybe . Text.unpack) . Text.splitOn (Text.pack ".") + let ghcVersion = Data.Maybe.fromJust $ parseVersion $ Text.pack VERSION_ghc + let checkVersion = \case + Nothing -> True -- no version constraint + Just s -> case parseVersion s of + Nothing -> error $ "could not parse version " ++ Text.unpack s + Just v -> v <= ghcVersion hspec $ do groups `forM_` \(groupname, tests) -> do - describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do - (if pend then before_ pending else id) - $ it (Text.unpack name) - $ roundTripEqual defaultTestConfig inp + describe (Text.unpack groupname) $ do + tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + (if isPending test then before_ pending else id) + $ it (Text.unpack $ testName test) + $ roundTripEqual defaultTestConfig + $ content test groupsCtxFree `forM_` \(groupname, tests) -> do - describe ("context free: " ++ Text.unpack groupname) - $ tests - `forM_` \(name, pend, inp) -> do - (if pend then before_ pending else id) - $ it (Text.unpack name) - $ roundTripEqual contextFreeTestConfig inp + describe ("context free: " ++ Text.unpack groupname) $ do + tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + (if isPending test then before_ pending else id) + $ it (Text.unpack $ testName test) + $ roundTripEqual contextFreeTestConfig + $ content test where -- this function might be implemented in a weirdly complex fashion; the -- reason being that it was copied from a somewhat more complex variant. - createChunks :: Text -> [(Text, [(Text, Bool, Text)])] + createChunks :: Text -> [(Text, [TestCase])] createChunks input = -- fmap (\case -- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines) @@ -73,35 +98,39 @@ main = do -- l -> error $ "first non-empty line must start with #test footest\n" ++ show l -- ) -- $ fmap (groupBy grouperT) - fmap - ( \case - GroupLine g:grouprest -> - (,) g - $ fmap - ( \case - HeaderLine n:PendingLine:rest | Just rlines <- mapM - extractNormal - rest -> - (n, True, Text.unlines rlines) - HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> - (n, False, Text.unlines rlines) - l -> - error - $ "first non-empty line must start with #test footest\n" - ++ show l - ) - $ groupBy grouperT - $ filter (not . lineIsSpace) - $ grouprest - l -> error $ "first non-empty line must be a #group\n" ++ show l - ) - $ groupBy grouperG - $ filter (not . lineIsSpace) - $ lineMapper - <$> Text.lines input + fmap groupProcessor + $ groupBy grouperG + $ filter (not . lineIsSpace) + $ fmap lineMapper + $ Text.lines input where + groupProcessor :: [InputLine] -> (Text, [TestCase]) + groupProcessor = \case + GroupLine g : grouprest -> + (,) g + $ fmap testProcessor + $ groupBy grouperT + $ filter (not . lineIsSpace) + $ grouprest + l -> error $ "first non-empty line must be a #group\n" ++ show l + testProcessor :: [InputLine] -> TestCase + testProcessor = \case + HeaderLine n : rest -> + let normalLines = Data.Maybe.mapMaybe extractNormal rest + in TestCase + { testName = n + , isPending = any isPendingLine rest + , minGHCVersion = Data.List.Extra.firstJust extractMinGhc rest + , content = Text.unlines normalLines + } + l -> + error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l extractNormal _ = Nothing + extractMinGhc (GhcVersionGuardLine v) = Just v + extractMinGhc _ = Nothing + isPendingLine PendingLine{} = True + isPendingLine _ = False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name @@ -116,6 +145,11 @@ main = do , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , _ <- Parsec.eof ] + , [ GhcVersionGuardLine $ Text.pack version + | _ <- Parsec.try $ Parsec.string "#min-ghc" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" + , version <- Parsec.many1 $ Parsec.noneOf "\r\n:" + ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") @@ -123,8 +157,8 @@ main = do ] , [ CommentLine | _ <- Parsec.many $ Parsec.oneOf " \t" - , _ <- - Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n") + , _ <- Parsec.optional $ Parsec.string "##" <* many + (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] ] @@ -148,8 +182,7 @@ main = do -------------------- roundTripEqual :: Config -> Text -> Expectation roundTripEqual c t = - fmap (fmap PPTextWrapper) - (parsePrintModuleTests c "TestFakeFileName.hs" t) + fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text @@ -158,7 +191,8 @@ newtype PPTextWrapper = PPTextWrapper Text instance Show PPTextWrapper where show (PPTextWrapper t) = "\n" ++ Text.unpack t - +-- brittany-next-binding --columns 160 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } defaultTestConfig :: Config defaultTestConfig = Config { _conf_version = _conf_version staticDefaultConfig @@ -181,21 +215,18 @@ defaultTestConfig = Config , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) - { _econf_omit_output_valid_check = coerce True - } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_obfuscate = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config -contextFreeTestConfig = - defaultTestConfig +contextFreeTestConfig = defaultTestConfig { _conf_layout = (_conf_layout defaultTestConfig) - {_lconfig_indentPolicy = coerce IndentPolicyLeft - ,_lconfig_alignmentLimit = coerce (1 :: Int) - ,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } + { _lconfig_indentPolicy = coerce IndentPolicyLeft + , _lconfig_alignmentLimit = coerce (1 :: Int) + , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled + } } -- 2.30.2 From a23ef696e8c63ab7a3f55100faf3504e66e9b6c2 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 7 Nov 2019 10:45:44 +0100 Subject: [PATCH 295/478] Fix test failure: DerivingStrategies exists since ghc-8.2 --- src-literatetests/10-tests.blt | 1 + 1 file changed, 1 insertion(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 44e82e0..1701b1d 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -351,6 +351,7 @@ data Foo = Bar deriving (Show, Eq, Monad, Functor, Traversable, Foldable) #test record multiple deriving strategies +#min-ghc 8.2 data Foo = Bar { foo :: Baz , bars :: Bizzz -- 2.30.2 From 9494d6203a16138252c8147c315a03bef540d65d Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Thu, 7 Nov 2019 14:54:42 -0600 Subject: [PATCH 296/478] Allow multi line formatting of normal records Only single line formatting of normal records was being supported. For records with long names we need multi line formatting. This also needs to support both multi and left indentation policies. --- src-literatetests/10-tests.blt | 18 ++++++++++++ .../Brittany/Internal/Layouters/DataDecl.hs | 28 +++++++++++++++---- 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1701b1d..0c1adfd 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -447,6 +447,24 @@ data Foo = Bar ABC --g ) +#test normal records on multi line indent policy left +-- brittany {lconfig_indentPolicy: IndentPolicyLeft } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy free +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy multiple +-- brittany {lconfig_indentPolicy: IndentPolicyMultiple } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 5dbb8db..2214478 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -266,11 +266,29 @@ docDeriving = docLit $ Text.pack "deriving" createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of - PrefixCon args -> docSeq - [ docLit consNameStr - , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType - ] + PrefixCon args -> do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + singleLine = docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + leftIndented = docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType <$> args + multiIndented = docSetParSpacing + . docSetBaseAndIndent + . docPar (docLit consNameStr) + . docLines + $ layoutType + <$> args + case indentPolicy of + IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyMultiple -> docAlt [singleLine, multiIndented] + IndentPolicyFree -> docAlt [singleLine, multiIndented] RecCon (L _ []) -> docEmpty #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> docSeq -- 2.30.2 From c367b1017b390de5b37de25fe8a3cc98b6f13ac8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Nov 2019 12:06:08 +0100 Subject: [PATCH 297/478] Fixup src-literatetests/Main formatting --- src-literatetests/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 93ae27a..82f97cb 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -215,7 +215,7 @@ defaultTestConfig = Config , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False -- 2.30.2 From 0381b9fe24172bb17b890a276f866d34fb17bb44 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Nov 2019 12:14:01 +0100 Subject: [PATCH 298/478] Fix record field comment indentation --- src-literatetests/10-tests.blt | 7 ++++++ .../Brittany/Internal/Layouters/DataDecl.hs | 23 ++++++++++--------- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 0c1adfd..40a8852 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -392,6 +392,13 @@ data Foo = forall a b . (Show a, Eq b) => Bar data MyData = MyData Int -- after +#test record newline comment +data MyRecord = MyRecord + { a :: Int + -- comment + , b :: Int + } + #test record comments simple data Foo = Bar -- a { foo :: Baz -- b diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 2214478..19ec610 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -291,21 +291,22 @@ createDetailsDoc consNameStr details = case details of IndentPolicyFree -> docAlt [singleLine, multiIndented] RecCon (L _ []) -> docEmpty #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> #else - RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> #endif - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLit $ Text.pack "{" - , docSeparator - , docWrapNodeRest lRec $ docSeq $ createNamesAndTypeDoc lField names t - , docSeparator - , docLit $ Text.pack "}" - ] + docSetIndentLevel $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLit $ Text.pack "{" + , docSeparator + , docWrapNodeRest lRec $ docSeq $ fmap docForceSingleline $ createNamesAndTypeDoc lField names t + , docSeparator + , docLit $ Text.pack "}" + ] RecCon lRec@(L _ fields@(_:_)) -> do let (fDoc1 : fDocR) = mkFieldDocs fields - docAddBaseY BrIndentRegular $ docPar + docAddBaseY BrIndentRegular $ docSetIndentLevel $ docPar (docLit consNameStr) (docWrapNodePrior lRec $ docLines [ docCols ColRecDecl -- 2.30.2 From 80f370a8e10690e65718f66dd72de12d6d771f05 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Tue, 12 Nov 2019 16:02:14 -0600 Subject: [PATCH 299/478] Support nullary data types Add tests for nullary prefix data types and nullary record data types. --- src-literatetests/10-tests.blt | 5 +++++ src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 40a8852..0a3140b 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -318,6 +318,11 @@ func = f ############################################################################### ############################################################################### +#test nullary data type +data Foo = Bar {} + +data Biz = Baz + #test single record data Foo = Bar { foo :: Baz } diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 19ec610..4bb2a98 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -289,7 +289,7 @@ createDetailsDoc consNameStr details = case details of IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiIndented] IndentPolicyFree -> docAlt [singleLine, multiIndented] - RecCon (L _ []) -> docEmpty + RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> #else -- 2.30.2 From 5a49277eba71e124fb822706427c157af0f68dff Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 25 Nov 2019 11:59:25 +0100 Subject: [PATCH 300/478] Improve data decl layouting - Fix bug in BackendUtil/lowest level of brittany about alignment being ignored after a comment, - Properly layout large (more than single-line) types in record fields and in data decl rhs arguments, - Properly layout data decl constructors with large "heads" (forall, constraints), - Add a config flag to control single-line layout of record definition, --- src-literatetests/10-tests.blt | 116 ++++++- src-literatetests/30-tests-context-free.blt | 8 +- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/BackendUtils.hs | 8 +- .../Haskell/Brittany/Internal/Config.hs | 2 + .../Haskell/Brittany/Internal/Config/Types.hs | 8 + .../Brittany/Internal/LayouterBasics.hs | 4 + .../Brittany/Internal/Layouters/DataDecl.hs | 327 +++++++++++++----- 9 files changed, 368 insertions(+), 107 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 0a3140b..2e46148 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -324,10 +324,14 @@ data Foo = Bar {} data Biz = Baz #test single record -data Foo = Bar { foo :: Baz } +data Foo = Bar + { foo :: Baz + } #test record multiple names -data Foo = Bar { foo, bar :: Baz } +data Foo = Bar + { foo, bar :: Baz + } #test record multiple types data Foo = Bar @@ -348,6 +352,91 @@ data Foo = Bar } deriving Show +#test record long field names +data MyRecord = MyConstructor + { bar1, bar2 + :: Loooooooooooooooooooooooooooooooong + -> Loooooooooooooooooooooooooooooooong + , foo1, foo2 + :: Loooooooooooooooooooooooooooooooonger + -> Loooooooooooooooooooooooooooooooonger + } + +#test record with DataTypeContexts +{-# LANGUAGE DatatypeContexts #-} +data + ( LooooooooooooooooooooongConstraint a + , LooooooooooooooooooooongConstraint b + ) => + MyRecord a b + = MyConstructor + { foo1, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + +#test record single line layout +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int } + +#test record no matching single line layout +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => Bar + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } + +#test record forall constraint multiline +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a + . LooooooooooooooooooooongConstraint a => + LoooooooooooongConstructor + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } + +#test record forall constraint multiline more +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { a :: a + , b :: b + } + +#test plain with forall and constraint +{-# LANGUAGE ScopedTypeVariables #-} +data MyStruct + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + +#test record with many features +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { foo, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + deriving Show + #test record multiple types deriving data Foo = Bar { foo :: Baz @@ -382,7 +471,9 @@ data Foo = Bar #test single record existential {-# LANGUAGE ExistentialQuantification #-} -data Foo = forall a . Show a => Bar { foo :: a } +data Foo = forall a . Show a => Bar + { foo :: a + } #test record multiple types existential {-# LANGUAGE ExistentialQuantification #-} @@ -415,8 +506,8 @@ data Foo = Bar -- a data Foo = Bar { -- a foo -- b - :: -- c - Baz -- d + :: -- c + Baz -- d , -- e bars :: Bizzz } @@ -467,16 +558,19 @@ data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse #test normal records on multi line indent policy free -- brittany {lconfig_indentPolicy: IndentPolicyFree } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy free 2 +-- brittany {lconfig_indentPolicy: IndentPolicyFree } data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] + Types.Company + [EnterpriseGrantResponse] #test normal records on multi line indent policy multiple -- brittany {lconfig_indentPolicy: IndentPolicyMultiple } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] - +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] ############################################################################### ############################################################################### diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 9a09fde..ba84a7c 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -321,10 +321,14 @@ func = f ############################################################################### #test single record -data Foo = Bar { foo :: Baz } +data Foo = Bar + { foo :: Baz + } #test record multiple names -data Foo = Bar { foo, bar :: Baz } +data Foo = Bar + { foo, bar :: Baz + } #test record multiple types data Foo = Bar diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 82f97cb..d0b9094 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -214,6 +214,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index d9555cc..f2dc542 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -61,6 +61,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 508a18c..bf30a4e 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -245,9 +245,10 @@ layoutWriteEnsureAbsoluteN -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let diff = case _lstate_curYOrAddNewline state of - Left i -> n - i - Right{} -> n + let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c , _ ) -> n - c + (Nothing, Left i ) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to @@ -557,6 +558,7 @@ layoutWritePostComments ast = do ) -> do replicateM_ x layoutWriteNewline layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } layoutWriteAppendMultiline $ Text.pack $ comment layoutIndentRestorePostComment diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 5d220fd..9dac6b7 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -77,6 +77,7 @@ staticDefaultConfig = Config , _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -181,6 +182,7 @@ cmdlineConfigParser = do , _lconfig_allowSingleLineExportList = mempty , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty + , _lconfig_allowSinglelineRecord = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 29711c5..526afef 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -142,6 +142,14 @@ data CLayoutConfig f = LayoutConfig -- The implementation for this is a bit hacky and not tested; it might -- break output syntax or not work properly for every kind of brace. So -- far I have considered `do` and `case-of`. + , _lconfig_allowSinglelineRecord :: f (Last Bool) + -- if true, layouts record data decls as a single line when possible, e.g. + -- > MyPoint { x :: Double, y :: Double } + -- if false, always use the multi-line layout + -- > MyPoint + -- > { x :: Double + -- > , y :: Double + -- > } } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d7acf16..d46421e 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -13,6 +13,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , filterAnns , docEmpty , docLit + , docLitS , docAlt , CollectAltM , addAlternativeCond @@ -481,6 +482,9 @@ docEmpty = allocateNode BDFEmpty docLit :: Text -> ToBriDocM BriDocNumbered docLit t = allocateNode $ BDFLit t +docLitS :: String -> ToBriDocM BriDocNumbered +docLitS s = allocateNode $ BDFLit $ Text.pack s + docExt :: (ExactPrint.Annotate.Annotate ast) => Located ast diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 4bb2a98..e11acfa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -59,17 +59,17 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLit (Text.pack "newtype") + -- [ appSep $ docLitS "newtype") -- , appSep $ docLit nameStr -- , appSep tyVarLine -- ] rhsDoc <- fmap return $ createDetailsDoc consNameStr details createDerivingPar mDerivs $ docSeq - [ appSep $ docLit (Text.pack "newtype") + [ appSep $ docLitS "newtype" , appSep $ docLit nameStr , appSep tyVarLine , docSeparator - , docLit (Text.pack "=") + , docLitS "=" , docSeparator , rhsDoc ] @@ -88,7 +88,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of nameStr <- lrdrNameToTextAnn name tyVarLine <- fmap return $ createBndrDoc bndrs createDerivingPar mDerivs $ docSeq - [ appSep $ docLit (Text.pack "data") + [ appSep $ docLitS "data" , lhsContextDoc , appSep $ docLit nameStr , appSep tyVarLine @@ -112,22 +112,115 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs - forallDoc <- docSharedWrapper createForallDoc qvars - rhsContextDoc <- case mRhsContext of - Nothing -> return docEmpty - Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt + forallDocMay <- case createForallDoc qvars of + Nothing -> pure Nothing + Just x -> Just . pure <$> x + rhsContextDocMay <- case mRhsContext of + Nothing -> pure Nothing + Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt rhsDoc <- fmap return $ createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLit (Text.pack "data") - , lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLit (Text.pack "=") - , docSeparator - , forallDoc - , rhsContextDoc - , rhsDoc + consDoc <- fmap pure + $ docNonBottomSpacing + $ case (forallDocMay, rhsContextDocMay) of + (Just forallDoc, Just rhsContextDoc) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq + [ docLitS "." + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + ] + (Just forallDoc, Nothing) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq [docLitS ".", docSeparator, rhsDoc] + ] + (Nothing, Just rhsContextDoc) -> docSeq + [ docLitS "=" + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] + createDerivingPar mDerivs $ docAlt + [ -- data D = forall a . Show a => D a + docSeq + [ appSep $ docLitS "data" + , docForceSingleline $ lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + , -- data D + -- = forall a . Show a => D a + docAddBaseY BrIndentRegular $ docPar + ( docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + ( docSeq + [ docLitS "=" + , docSeparator + , case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ) + , -- data D + -- = forall a + -- . Show a => + -- D a + docAddBaseY BrIndentRegular $ docPar + ( docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + consDoc + , -- data + -- Show a => + -- D + -- = forall a + -- . Show a => + -- D a + -- This alternative is only for -XDatatypeContexts. + -- But I think it is rather unlikely this will trigger without + -- -XDataTypeContexts, especially with the `docNonBottomSpacing` + -- above, so while not strictly necessary, this should not + -- hurt. + docAddBaseY BrIndentRegular $ docPar + (docLitS "data") + ( docLines + [ lhsContextDoc + , docSeq + [ appSep $ docLit nameStr + , tyVarLine + ] + , consDoc + ] + ) ] _ -> briDocByExactNoComment ltycl @@ -136,13 +229,25 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered createContextDoc [] = docEmpty createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] -createContextDoc ts = docSeq - [ docLit (Text.pack "(") - , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) - , docLit (Text.pack ") =>") - , docSeparator - ] + docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] +createContextDoc (t1 : tR) = do + t1Doc <- docSharedWrapper layoutType t1 + tRDocs <- tR `forM` docSharedWrapper layoutType + docAlt + [ docSeq + [ docLitS "(" + , docForceSingleline $ docSeq $ List.intersperse docCommaSep + (t1Doc : tRDocs) + , docLitS ") =>" + , docSeparator + ] + , docLines $ join + [ [docSeq [docLitS "(", docSeparator, t1Doc]] + , tRDocs + <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , [docLitS ") =>", docSeparator] + ] + ] createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do @@ -165,13 +270,13 @@ createBndrDoc bs = do <&> \(vname, mKind) -> case mKind of Nothing -> docLit vname Just kind -> docSeq - [ docLit (Text.pack "(") + [ docLitS "(" , docLit vname , docSeparator - , docLit (Text.pack "::") + , docLitS "::" , docSeparator , kind - , docLit (Text.pack ")") + , docLitS ")" ] createDerivingPar @@ -179,7 +284,7 @@ createDerivingPar createDerivingPar derivs mainDoc = do case derivs of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ - (L _ []) -> docLines [mainDoc] + (L _ []) -> mainDoc (L _ types) -> docPar mainDoc $ docEnsureIndent BrIndentRegular @@ -188,7 +293,7 @@ createDerivingPar derivs mainDoc = do $ derivingClauseDoc <$> types #else - Nothing -> docLines [mainDoc] + Nothing -> mainDoc Just types -> docPar mainDoc $ docEnsureIndent BrIndentRegular @@ -213,7 +318,7 @@ derivingClauseDoc types = case types of let tsLength = length ts whenMoreThan1Type val = - if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "") + if tsLength > 1 then docLitS val else docLitS "" #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy #else @@ -243,15 +348,15 @@ derivingClauseDoc types = case types of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */ where strategyLeftRight = \case - (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) - (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) - (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) + (L _ StockStrategy ) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ lVia@(L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of HsIB _ext t -> docSeq - [ docWrapNode lVia $ docLit $ Text.pack " via" + [ docWrapNode lVia $ docLitS " via" , docSeparator , layoutType t ] @@ -261,62 +366,109 @@ derivingClauseDoc types = case types of #endif docDeriving :: ToBriDocM BriDocNumbered -docDeriving = docLit $ Text.pack "deriving" +docDeriving = docLitS "deriving" createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq [ docLit consNameStr , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType + , docForceSingleline + $ docSeq + $ List.intersperse docSeparator + $ args <&> layoutType ] leftIndented = docSetParSpacing . docAddBaseY BrIndentRegular . docPar (docLit consNameStr) . docLines $ layoutType <$> args - multiIndented = docSetParSpacing - . docSetBaseAndIndent - . docPar (docLit consNameStr) - . docLines - $ layoutType - <$> args + multiAppended = docSeq + [ docLit consNameStr + , docSeparator + , docSetBaseY $ docLines $ layoutType <$> args + ] + multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + (docLit consNameStr) + (docLines $ layoutType <$> args) case indentPolicy of IndentPolicyLeft -> docAlt [singleLine, leftIndented] - IndentPolicyMultiple -> docAlt [singleLine, multiIndented] - IndentPolicyFree -> docAlt [singleLine, multiIndented] + IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] + IndentPolicyFree -> + docAlt [singleLine, multiAppended, multiIndented, leftIndented] RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> -#else - RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> -#endif - docSetIndentLevel $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLit $ Text.pack "{" - , docSeparator - , docWrapNodeRest lRec $ docSeq $ fmap docForceSingleline $ createNamesAndTypeDoc lField names t - , docSeparator - , docLit $ Text.pack "}" - ] RecCon lRec@(L _ fields@(_:_)) -> do - let (fDoc1 : fDocR) = mkFieldDocs fields - docAddBaseY BrIndentRegular $ docSetIndentLevel $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docLines - [ docCols ColRecDecl - $ appSep (docLit (Text.pack "{")) - : fDoc1 - , docWrapNodeRest lRec $ docLines $ fDocR <&> \f -> - docCols ColRecDecl $ docCommaSep : f - , docLit $ Text.pack "}" - ] - ) + let ((fName1, fType1) : fDocR) = mkFieldDocs fields + allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + docAddBaseY BrIndentRegular + $ docSetIndentLevel + $ runFilteredAlternative + $ do + -- single-line: { i :: Int, b :: Bool } + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR + ] + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docLines + [ docAlt + [ docCols ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName + , docSeq [docLitS "::", docSeparator] + , docForceSingleline fType + ] + , docSeq + [ docLitS "," + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName + (docSeq [docLitS "::", docSeparator, fType]) + ] + ] + , docLitS "}" + ] + ) InfixCon arg1 arg2 -> docSeq [ layoutType arg1 , docSeparator @@ -325,7 +477,9 @@ createDetailsDoc consNameStr details = case details of , layoutType arg2 ] where - mkFieldDocs :: [LConDeclField GhcPs] -> [[ToBriDocM BriDocNumbered]] + mkFieldDocs + :: [LConDeclField GhcPs] + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] mkFieldDocs = fmap $ \lField -> case lField of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t @@ -334,23 +488,19 @@ createDetailsDoc consNameStr details = case details of L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t #endif -createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered -createForallDoc [] = docEmpty -createForallDoc lhsTyVarBndrs = docSeq - [ docLit (Text.pack "forall ") - , createBndrDoc lhsTyVarBndrs - , docLit (Text.pack " .") - , docSeparator - ] +createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = Just $ docSeq + [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc :: Data.Data.Data ast => Located ast -> [GenLocated t (FieldOcc GhcPs)] -> Located (HsType GhcPs) - -> [ToBriDocM BriDocNumbered] + -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = - [ docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq + ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq [ docSeq $ List.intersperse docCommaSep $ names @@ -362,11 +512,6 @@ createNamesAndTypeDoc lField names t = L _ (FieldOcc fieldName _) -> #endif docLit =<< lrdrNameToTextAnn fieldName - , docSeparator ] - , docWrapNodeRest lField $ docSeq - [ docLit $ Text.pack "::" - , docSeparator - , layoutType t - ] - ] + , docWrapNodeRest lField $ layoutType t + ) -- 2.30.2 From 6c3d9c57c5fc730673b932b11287412d1cf9fef7 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Nov 2019 21:19:10 +0100 Subject: [PATCH 301/478] Comment the single-line record decl config flag out --- src-literatetests/10-tests.blt | 1 + src-literatetests/Main.hs | 2 +- src-unittests/TestUtils.hs | 2 +- src/Language/Haskell/Brittany/Internal/Config.hs | 4 ++-- .../Haskell/Brittany/Internal/Config/Types.hs | 16 ++++++++-------- .../Brittany/Internal/Layouters/DataDecl.hs | 3 ++- 6 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 2e46148..7dc1e45 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -378,6 +378,7 @@ data } #test record single line layout +#pending config flag is disabled for now {-# LANGUAGE ScopedTypeVariables #-} -- brittany { lconfig_allowSinglelineRecord: true } data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int } diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index d0b9094..3595b1f 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -214,7 +214,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False - , _lconfig_allowSinglelineRecord = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index f2dc542..3f24266 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -61,7 +61,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False - , _lconfig_allowSinglelineRecord = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 9dac6b7..a5bbdbd 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -77,7 +77,7 @@ staticDefaultConfig = Config , _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False - , _lconfig_allowSinglelineRecord = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -182,7 +182,7 @@ cmdlineConfigParser = do , _lconfig_allowSingleLineExportList = mempty , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty - , _lconfig_allowSinglelineRecord = mempty + -- , _lconfig_allowSinglelineRecord = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 526afef..a244eae 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -142,14 +142,14 @@ data CLayoutConfig f = LayoutConfig -- The implementation for this is a bit hacky and not tested; it might -- break output syntax or not work properly for every kind of brace. So -- far I have considered `do` and `case-of`. - , _lconfig_allowSinglelineRecord :: f (Last Bool) - -- if true, layouts record data decls as a single line when possible, e.g. - -- > MyPoint { x :: Double, y :: Double } - -- if false, always use the multi-line layout - -- > MyPoint - -- > { x :: Double - -- > , y :: Double - -- > } + -- , _lconfig_allowSinglelineRecord :: f (Last Bool) + -- -- if true, layouts record data decls as a single line when possible, e.g. + -- -- > MyPoint { x :: Double, y :: Double } + -- -- if false, always use the multi-line layout + -- -- > MyPoint + -- -- > { x :: Double + -- -- > , y :: Double + -- -- > } } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index e11acfa..fb4205d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -403,7 +403,8 @@ createDetailsDoc consNameStr details = case details of RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] RecCon lRec@(L _ fields@(_:_)) -> do let ((fName1, fType1) : fDocR) = mkFieldDocs fields - allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + let allowSingleline = False docAddBaseY BrIndentRegular $ docSetIndentLevel $ runFilteredAlternative -- 2.30.2 From 3fbbf3d661a0a54096075042d15d8262ca1dfb48 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Nov 2019 21:19:36 +0100 Subject: [PATCH 302/478] Fix one misplaced comment bug on data decls --- .../Brittany/Internal/Layouters/DataDecl.hs | 22 ++++++++++++------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index fb4205d..dd3576f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -143,11 +143,14 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ appSep $ docLitS "data" - , docForceSingleline $ lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator + [ docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline $ lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + ] , docLitS "=" , docSeparator , case forallDocMay of @@ -164,7 +167,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - ( docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -191,7 +195,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - ( docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -214,7 +219,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of (docLitS "data") ( docLines [ lhsContextDoc - , docSeq + , docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLit nameStr , tyVarLine ] -- 2.30.2 From a1282c3ac670b61e6bbcd50cf7a12612b385b2e5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Nov 2019 21:51:33 +0100 Subject: [PATCH 303/478] Add a testcase for the last commit --- src-literatetests/10-tests.blt | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 7dc1e45..684a711 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -551,6 +551,16 @@ data Foo = Bar ABC --g ) +#test comment before equal sign +{-# LANGUAGE ExistentialQuantification #-} +data MyRecord + -- test comment + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor a b + #test normal records on multi line indent policy left -- brittany {lconfig_indentPolicy: IndentPolicyLeft } data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse -- 2.30.2 From 00c6854887f3de22f5e036f652d6f16748a78be4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 9 Dec 2019 22:35:26 +0100 Subject: [PATCH 304/478] Fix two minor data-decl layouting issues --- src-literatetests/10-tests.blt | 24 ++++++ .../Haskell/Brittany/Internal/Backend.hs | 22 ++--- .../Brittany/Internal/LayouterBasics.hs | 6 +- .../Brittany/Internal/Layouters/DataDecl.hs | 47 +++++----- .../Brittany/Internal/Transformations/Alt.hs | 37 ++++++-- .../Internal/Transformations/Columns.hs | 2 +- .../Haskell/Brittany/Internal/Types.hs | 85 ++++++++++--------- 7 files changed, 138 insertions(+), 85 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 684a711..a3d1138 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -583,6 +583,30 @@ data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse data GrantsForCompanyResp = GrantsForCompanyResp Types.Company [EnterpriseGrantResponse] +#test large record with a comment +data XIILqcacwiuNiu = XIILqcacwiuNiu + { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo + , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] + , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo + , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo + , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int + , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq + , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq + , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo + , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn + , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo + , opjUxtkxzkiKse_luqjuZazt + :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] + -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () + , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo + , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn + , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn + , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn + , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn + , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep + , jeyOcuesexaYoy_vpqn :: Jgtoyuh () + } + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 32c5aba..50522ed 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -287,7 +287,7 @@ layoutBriDocM = \case Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd - BDNonBottomSpacing bd -> layoutBriDocM bd + BDNonBottomSpacing _ bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do @@ -321,15 +321,15 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_:_) -> do + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd - BDDebug _ bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc @@ -363,9 +363,9 @@ briDocIsMultiLine briDoc = rec briDoc BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd BDDebug _ bd -> rec bd -- In theory diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d46421e..6263f50 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -40,6 +40,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docAnnotationRest , docMoveToKWDP , docNonBottomSpacing + , docNonBottomSpacingS , docSetParSpacing , docForceParSpacing , docDebug @@ -576,7 +577,10 @@ docAnnotationRest docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm + +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index dd3576f..00453b3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -153,16 +153,18 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ] , docLitS "=" , docSeparator - , case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] ] , -- data D -- = forall a . Show a => D a @@ -178,16 +180,18 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ( docSeq [ docLitS "=" , docSeparator - , case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] ] ) , -- data D @@ -412,7 +416,6 @@ createDetailsDoc consNameStr details = case details of -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False docAddBaseY BrIndentRegular - $ docSetIndentLevel $ runFilteredAlternative $ do -- single-line: { i :: Int, b :: Bool } @@ -441,7 +444,7 @@ createDetailsDoc consNameStr details = case details of ] addAlternative $ docPar (docLit consNameStr) - (docWrapNodePrior lRec $ docLines + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines [ docAlt [ docCols ColRecDecl [ appSep (docLitS "{") diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 22d0555..6a15eac 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -331,7 +331,7 @@ transformAlts = BrIndentNone -> r BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing bd -> rec bd + BDFNonBottomSpacing _ bd -> rec bd BDFSetParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd BDFDebug s bd -> do @@ -488,13 +488,18 @@ getSpacing !bridoc = rec bridoc BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do mVs <- rec bd return $ mVs - <|> LineModeValid (VerticalSpacing 0 - (VerticalSpacingParAlways colMax) - False) + <|> LineModeValid + (VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } @@ -799,16 +804,30 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. mVs <- rec bd return $ if null mVs - then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] + then [VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] else mVs <&> \vs -> vs { _vs_sameLine = min colMax (_vs_sameLine vs) , _vs_paragraph = case _vs_paragraph vs of VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - VerticalSpacingParSome i -> VerticalSpacingParAlways i + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i } -- the version below is an alternative idea: fold the input -- spacings into a single spacing. This was hoped to improve in diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 31ec86a..d652dda 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -135,4 +135,4 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing BDDebug{} -> Nothing - BDNonBottomSpacing x -> Just x + BDNonBottomSpacing _ x -> Just x diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index e3a5318..c8e37ff 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -258,7 +258,7 @@ data BriDoc -- after the alt transformation. | BDForceMultiline BriDoc | BDForceSingleline BriDoc - | BDNonBottomSpacing BriDoc + | BDNonBottomSpacing Bool BriDoc | BDSetParSpacing BriDoc | BDForceParSpacing BriDoc -- pseudo-deprecated @@ -303,7 +303,7 @@ data BriDocF f | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing (f (BriDocF f)) + | BDFNonBottomSpacing Bool (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f)) | BDFDebug String (f (BriDocF f)) @@ -315,33 +315,37 @@ type BriDocFInt = BriDocF ((,) Int) type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd - uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd - uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd) = plate BDDebug |- s |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x + uniplate (BDAnnotationPrior annKey bd) = + plate BDAnnotationPrior |- annKey |* bd + uniplate (BDAnnotationKW annKey kw bd) = + plate BDAnnotationKW |- annKey |- kw |* bd + uniplate (BDAnnotationRest annKey bd) = + plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw b bd) = + plate BDMoveToKWDP |- annKey |- kw |- b |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int @@ -369,14 +373,13 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where - rec = unwrapBriDocNumbered + where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False @@ -406,11 +409,11 @@ briDocSeqSpine = \case BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc -- 2.30.2 From 6724760f408e4e6d9640a663ed1bd51af0380893 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 20 Dec 2019 01:12:25 +0100 Subject: [PATCH 305/478] Fix non-idempotent newlines with comment + where (#263) --- src-literatetests/15-regressions.blt | 12 ++++++++++++ src/Language/Haskell/Brittany/Internal.hs | 1 + src/Language/Haskell/Brittany/Internal/Backend.hs | 10 ++++++---- .../Haskell/Brittany/Internal/BackendUtils.hs | 6 +++++- src/Language/Haskell/Brittany/Internal/Types.hs | 6 ++++++ 5 files changed, 30 insertions(+), 5 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 07cc3a9..ce2d617 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -770,3 +770,15 @@ vakjkeSulxudbFokvir = Duotpo , -- N.B. .. -- x } + +#test issue 263 + +func = abc + def + -- a + -- b + + -- comment + + where + abc = 13 + def = 1 diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index b0680a7..e98c0fc 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -651,6 +651,7 @@ layoutBriDoc briDoc = do , _lstate_comments = anns , _lstate_commentCol = Nothing , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 50522ed..a33edca 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -279,12 +279,14 @@ layoutBriDocM = \case , keyword == kw1 ] -- mTell $ Seq.fromList ["KWDP: " ++ show annKey ++ " " ++ show mAnn] - pure $ case relevant of - [] -> Nothing - (dp:_) -> Just dp + case relevant of + [] -> pure Nothing + (ExactPrint.Types.DP (y, x):_) -> do + mSet state { _lstate_commentNewlines = 0 } + pure $ Just (y - _lstate_commentNewlines state, x) case mDP of Nothing -> pure () - Just (ExactPrint.Types.DP (y, x)) -> + Just (y, x) -> layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index bf30a4e..aa420fe 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -200,6 +200,7 @@ layoutMoveToCommentPos y x = do Nothing -> case _lstate_curYOrAddNewline state of Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Right{} -> lstate_baseY state + , _lstate_commentNewlines = _lstate_commentNewlines state + y } -- | does _not_ add spaces to again reach the current base column. @@ -217,6 +218,7 @@ layoutWriteNewline = do Left{} -> Right 1 Right i -> Right (i + 1) , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 } layoutWriteEnsureNewlineBlock @@ -574,7 +576,9 @@ layoutIndentRestorePostComment = do #if INSERTTRACES tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) #endif - mModify $ \s -> s { _lstate_commentCol = Nothing } + mModify $ \s -> s { _lstate_commentCol = Nothing + , _lstate_commentNewlines = 0 + } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index c8e37ff..ed7798e 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -84,6 +84,11 @@ data LayoutState = LayoutState -- -- captures if the layouter currently is in a new line, i.e. if the -- -- current line only contains (indentation) spaces. -- this is mostly superseeded by curYOrAddNewline, iirc. + , _lstate_commentNewlines :: Int -- number of newlines inserted due to + -- move-to-DP at a start of a comment. + -- Necessary because some keyword DPs + -- are relative to the last non-comment + -- entity (for some reason) } lstate_baseY :: LayoutState -> Int @@ -102,6 +107,7 @@ instance Show LayoutState where ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- 2.30.2 From af227a797d588eda936280dc1c3b0b376735335e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 20 Dec 2019 01:20:07 +0100 Subject: [PATCH 306/478] Add a few code comments --- src/Language/Haskell/Brittany/Internal/Backend.hs | 2 ++ src/Language/Haskell/Brittany/Internal/BackendUtils.hs | 2 ++ src/Language/Haskell/Brittany/Internal/Types.hs | 8 +++++++- 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index a33edca..2516f81 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -287,6 +287,8 @@ layoutBriDocM = \case case mDP of Nothing -> pure () Just (y, x) -> + -- we abuse this, as we probably will print the KW next, which is + -- _not_ a comment.. layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index aa420fe..2398508 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -173,6 +173,8 @@ layoutSetCommentCol = do unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } +-- This is also used to move to non-comments in a couple of places. Seems +-- to be harmless so far.. layoutMoveToCommentPos :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index ed7798e..109013f 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -88,7 +88,13 @@ data LayoutState = LayoutState -- move-to-DP at a start of a comment. -- Necessary because some keyword DPs -- are relative to the last non-comment - -- entity (for some reason) + -- entity (for some reason). + -- This is not very strictly reset to 0, + -- so we might in some cases get "artifacts" + -- from previous document elements. + -- But the worst effect at the moment would + -- be that we introduce less newlines on + -- moveToKWDP, which seems harmless enough. } lstate_baseY :: LayoutState -> Int -- 2.30.2 From 342cf16c564962a13c56665627cac301bb092923 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 3 Jan 2020 11:58:53 +0100 Subject: [PATCH 307/478] Improve error message printing - Omit unnecessary show-invocation - Use showOutputable for the error span (location) before/after: "RealSrcSpan SrcSpanPoint \"stdin\" 2 1: parse error (possibly incorrect indentation or mismatched brackets)" stdin:2:1: parse error (possibly incorrect indentation or mismatched brackets) --- src-brittany/Main.hs | 2 +- src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 527d2e8..423320b 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -325,7 +325,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = case parseResult of Left left -> do putErrorLn "parse error:" - putErrorLn $ show left + putErrorLn left ExceptT.throwE 60 Right (anns, parsedSource, hasCPP) -> do (inlineConf, perItemConf) <- diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 1fabf9c..0273d85 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -123,7 +123,7 @@ parseModuleFromString args fp dynCheck str = dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of - Left (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err + Left (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err Right (a , m ) -> pure (a, m, dynCheckRes) -- 2.30.2 From d0256bb0dba8d085ef2c19a48b46b79d5159abb0 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 3 Jan 2020 11:58:53 +0100 Subject: [PATCH 308/478] Make unknown syntax errors non-fatal/Fall back on exactprint --- src-brittany/Main.hs | 9 +++++---- src/Language/Haskell/Brittany/Internal.hs | 12 +++++++++--- .../Haskell/Brittany/Internal/LayouterBasics.hs | 12 +++++++++--- src/Language/Haskell/Brittany/Internal/Types.hs | 5 ++++- 4 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 423320b..ff59b4c 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -374,10 +374,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = else pure out pure $ (ews, out') let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorMacroConfig{} = 5 when (not $ null errsWarns) $ do let groupedErrsWarns = @@ -392,10 +392,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str uns@(ErrorUnknownNode{} : _) -> do - putErrorLn $ "ERROR: encountered unknown syntactical constructs:" + putErrorLn $ "WARNING: encountered unknown syntactical constructs:" uns `forM_` \case ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ str <> " at " <> showSDocUnsafe (ppr loc) + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) when ( config & _conf_debug @@ -405,6 +405,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = $ do putErrorLn $ " " ++ show (astToDoc ast) _ -> error "cannot happen (TM)" + putErrorLn " -> falling back on exactprint for this element of the module" warns@(LayoutWarning{} : _) -> do putErrorLn $ "WARNINGS:" warns `forM_` \case diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e98c0fc..f2e4c11 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -460,9 +460,15 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do - bd <- briDocMToPPM $ if exactprintOnly - then briDocByExactNoComment decl - else layoutDecl decl + bd <- if exactprintOnly + then briDocMToPPM $ briDocByExactNoComment decl + else do + (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl + mTell debugs + mTell errs + if null errs + then pure r + else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd let finalComments = filter diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 6263f50..76ec7a3 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -62,6 +62,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docTick , spacifyDocs , briDocMToPPM + , briDocMToPPMInner , allocateNode , docSharedWrapper , hasAnyCommentsBelow @@ -814,6 +815,13 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] briDocMToPPM :: ToBriDocM a -> PPMLocal a briDocMToPPM m = do + (x, errs, debugs) <- briDocMToPPMInner m + mTell debugs + mTell errs + return x + +briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) +briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR let ((x, errs), debugs) = runIdentity @@ -823,9 +831,7 @@ briDocMToPPM m = do $ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW $ m - mTell debugs - mTell errs - return x + pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) docSharedWrapper f x = return <$> f x diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 109013f..620a39b 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -215,7 +215,10 @@ data BrIndent = BrIndentNone | BrIndentSpecial Int deriving (Eq, Ord, Typeable, Data.Data.Data, Show) -type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex] +type ToBriDocM = MultiRWSS.MultiRWS + '[Config, Anns] -- reader + '[[BrittanyError], Seq String] -- writer + '[NodeAllocIndex] -- state type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -- 2.30.2 From 2b303b2a2048bc9218feefc893018a5108953689 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 10 Jan 2020 16:32:18 +0100 Subject: [PATCH 309/478] Fix additional indentation bug for let-in --- src-literatetests/15-regressions.blt | 16 ++++++++++++++++ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 2 +- .../Internal/Transformations/Floating.hs | 2 ++ 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index ce2d617..21eaf3d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -782,3 +782,19 @@ func = abc + def where abc = 13 def = 1 + +#test AddBaseY/EnsureIndent float in effect + +zItazySunefp twgq nlyo lwojjoBiecao = + let mhIarjyai = + ukwAausnfcn + $ XojlsTOSR.vuwOvuvdAZUOJaa + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.popjAyijoWarueeP + $ XojlsTOSR.jpwuPmafuDqlbkt nlyo + $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng + $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow + $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) + $ etOslnoz lwojjoBiecao + in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index df5ee2a..1a02ab8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -770,7 +770,7 @@ layoutExpr lexpr@(L _ expr) = do addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" , docNodeAnnKW lexpr (Just AnnLet) - $ appSep $ docForceSingleline bindDoc + $ appSep $ docForceSingleline bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ] diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 03c6c0c..4bb227b 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -132,6 +132,8 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDIndentLevelPop (BDAddBaseY ind x) BDAddBaseY ind (BDIndentLevelPushCur x) -> Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x _ -> Nothing stepBO :: BriDoc -> BriDoc stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ -- 2.30.2 From 128dd828c24e33d1e67db8f713692af72a88b8e0 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 11 Jan 2020 23:19:04 +0100 Subject: [PATCH 310/478] Fix newline issue on comments before where --- src-literatetests/15-regressions.blt | 4 +++ src/Language/Haskell/Brittany/Internal.hs | 20 ++------------ .../Haskell/Brittany/Internal/Backend.hs | 25 +++++++++-------- .../Haskell/Brittany/Internal/BackendUtils.hs | 27 +++++++++++-------- 4 files changed, 36 insertions(+), 40 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 21eaf3d..c61bb78 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -798,3 +798,7 @@ zItazySunefp twgq nlyo lwojjoBiecao = $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) $ etOslnoz lwojjoBiecao in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) + +#test module initial comment +-- test +module MyModule where diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e98c0fc..3fca4a1 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -520,7 +520,7 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do let (filteredAnns', post) = - case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of + case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> let @@ -536,23 +536,7 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - findInitialCommentSize = \case - ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)) : rest) -> - let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm - in y - + GHC.srcSpanEndLine span - - GHC.srcSpanStartLine span - + findInitialCommentSize rest - _ -> 0 - initialCommentSize = findInitialCommentSize pre - fixAbsoluteModuleDP = \case - (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> - (g, ExactPrint.DP (y - initialCommentSize, x)) - x -> x - pre' = if shouldReformatPreamble - then map fixAbsoluteModuleDP pre - else pre - mAnn' = mAnn { ExactPrint.annsDP = pre' } + mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns in diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 2516f81..3d29218 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -174,14 +174,15 @@ layoutBriDocM = \case priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do + let commentLines = Text.lines $ Text.pack $ comment case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } when allowMTEL $ moveToExactAnn annKey layoutBriDocM bd @@ -214,14 +215,15 @@ layoutBriDocM = \case Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do + let commentLines = Text.lines $ Text.pack $ comment -- evil hack for CPP: case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) - _ -> layoutMoveToCommentPos y x + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd @@ -256,17 +258,18 @@ layoutBriDocM = \case Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do + let commentLines = Text.lines $ Text.pack comment case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) + ('#':_) -> layoutMoveToCommentPos y (-999) 1 -- ^ evil hack for CPP ")" -> pure () -- ^ fixes the formatting of parens -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do @@ -278,7 +281,7 @@ layoutBriDocM = \case , (ExactPrint.Types.G kw1, dp) <- ann , keyword == kw1 ] - -- mTell $ Seq.fromList ["KWDP: " ++ show annKey ++ " " ++ show mAnn] + -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] case relevant of [] -> pure Nothing (ExactPrint.Types.DP (y, x):_) -> do @@ -289,7 +292,7 @@ layoutBriDocM = \case Just (y, x) -> -- we abuse this, as we probably will print the KW next, which is -- _not_ a comment.. - layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) + layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 2398508..2531794 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -122,12 +122,12 @@ layoutWriteAppendMultiline , MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m ) - => Text + => [Text] -> m () -layoutWriteAppendMultiline t = do - traceLocal ("layoutWriteAppendMultiline", t) - case Text.lines t of - [] -> layoutWriteAppend t -- need to write empty, too. +layoutWriteAppendMultiline ts = do + traceLocal ("layoutWriteAppendMultiline", ts) + case ts of + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. (l:lr) -> do layoutWriteAppend l lr `forM_` \x -> do @@ -182,9 +182,10 @@ layoutMoveToCommentPos ) => Int -> Int + -> Int -> m () -layoutMoveToCommentPos y x = do - traceLocal ("layoutMoveToCommentPos", y, x) +layoutMoveToCommentPos y x commentLines = do + traceLocal ("layoutMoveToCommentPos", y, x, commentLines) state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of @@ -202,7 +203,8 @@ layoutMoveToCommentPos y x = do Nothing -> case _lstate_curYOrAddNewline state of Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Right{} -> lstate_baseY state - , _lstate_commentNewlines = _lstate_commentNewlines state + y + , _lstate_commentNewlines = + _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column. @@ -220,9 +222,12 @@ layoutWriteNewline = do Left{} -> Right 1 Right i -> Right (i + 1) , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 } +_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () +_layoutResetCommentNewlines = do + mModify $ \state -> state { _lstate_commentNewlines = 0 } + layoutWriteEnsureNewlineBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m @@ -526,7 +531,7 @@ layoutWritePriorComments ast = do ) -> do replicateM_ x layoutWriteNewline layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. @@ -563,7 +568,7 @@ layoutWritePostComments ast = do replicateM_ x layoutWriteNewline layoutWriteAppend $ Text.pack $ replicate y ' ' mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment :: ( MonadMultiState LayoutState m -- 2.30.2 From 03e2b62c24afc1cbd48d46facf68d4c41f6597b6 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 23 Jan 2020 13:28:28 +0100 Subject: [PATCH 311/478] Introduce flag to disable formatting per-module New inline config `-- brittany-disable` that parses but ignores the current module. Useful if both brittany and ghc-exactprint bug out for some syntax. --- src-brittany/Main.hs | 22 ++--- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + src/Language/Haskell/Brittany/Internal.hs | 80 +++++++++++-------- .../Haskell/Brittany/Internal/Config.hs | 3 + .../Haskell/Brittany/Internal/Config/Types.hs | 8 +- .../Internal/Config/Types/Instances.hs | 1 + 7 files changed, 74 insertions(+), 42 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index ff59b4c..c064441 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -343,11 +343,16 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () - (errsWarns, outSText) <- do - if exactprintOnly - then do - pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns) - else do + let disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack + (errsWarns, outSText, hasChanges) <- do + if + | disableFormatting -> do + pure ([], originalContents, False) + | exactprintOnly -> do + let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + pure ([], r, r /= originalContents) + | otherwise -> do let omitCheck = moduleConf & _conf_errorHandling @@ -372,7 +377,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out - pure $ (ews, out') + pure $ (ews, out', out' /= originalContents) let customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorOutputCheck{} = 1 @@ -440,7 +445,6 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = & confUnpack shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) - let noChanges = outSText == originalContents when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of @@ -448,11 +452,11 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = Just p -> liftIO $ do let isIdentical = case inputPathM of Nothing -> False - Just _ -> noChanges + Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText when hasErrors $ ExceptT.throwE 70 - return (if noChanges then NoChanges else Changes) + return (if hasChanges then Changes else NoChanges) where addTraceSep conf = if or diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 3595b1f..19e940a 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -220,6 +220,7 @@ defaultTestConfig = Config , _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 3f24266..2e53f67 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -69,5 +69,6 @@ defaultTestConfig = Config , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 2bc91ba..7033354 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -160,6 +160,12 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + let disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) + Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do -- conf <- configParser @@ -266,38 +272,47 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf - (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource - else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s - pure $ if hackAroundIncludes - then - ( ews - , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn - (TextL.pack "\n") - outRaw - ) - else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - case moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL + let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack + if disableFormatting + then do + return inputText + else do + (errsWarns, outputTextL) <- do + let omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule moduleConfig perItemConf anns parsedSource + else lift + $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + pure $ if hackAroundIncludes + then + ( ews + , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn + (TextL.pack "\n") + outRaw + ) + else (ews, outRaw) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let hasErrors = + case + moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + if hasErrors + then throwE $ errsWarns + else pure $ TextL.toStrict outputTextL @@ -459,6 +474,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + when exactprintOnly $ mTell $ Text.Builder.fromText $ Text.pack "abc" toLocal config' filteredAnns $ do bd <- if exactprintOnly then briDocMToPPM $ briDocByExactNoComment decl diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index a5bbdbd..fc2e8cc 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -93,6 +93,7 @@ staticDefaultConfig = Config { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } @@ -147,6 +148,7 @@ cmdlineConfigParser = do ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config @@ -198,6 +200,7 @@ cmdlineConfigParser = do { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index a244eae..32da0ac 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -187,11 +187,17 @@ data CConfig f = Config , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - , _conf_obfuscate :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config -- implementation. Could have re-used the existing field, but felt risky -- to use a "debug" labeled field for non-debug functionality. + , _conf_disable_formatting :: f (Semigroup.Last Bool) + -- ^ Used for inline config that disables brittany entirely for this + -- module. Useful for wildcard application + -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something + -- in that direction). + , _conf_obfuscate :: f (Semigroup.Last Bool) + } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 82edaed..74dfe0e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -120,6 +120,7 @@ instance FromJSON (CConfig Maybe) where <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" <*> v .:? Text.pack "conf_roundtrip_exactprint_only" + <*> v .:? Text.pack "conf_disable_formatting" <*> v .:? Text.pack "conf_obfuscate" parseJSON invalid = Aeson.typeMismatch "Config" invalid -- 2.30.2 From fad9db8fd8b138c19a3bceb260bca0fd652a2b73 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 23 Jan 2020 13:34:07 +0100 Subject: [PATCH 312/478] Autoformat Config.hs --- .../Haskell/Brittany/Internal/Config.hs | 200 +++++++++--------- 1 file changed, 97 insertions(+), 103 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index fc2e8cc..520be3f 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -29,24 +29,28 @@ import qualified Data.Yaml import Data.CZipWith import UI.Butcher.Monadic -import Data.Monoid ((<>)) +import Data.Monoid ( (<>) ) -import qualified System.Console.CmdArgs.Explicit as CmdArgs +import qualified System.Console.CmdArgs.Explicit + as CmdArgs import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types.Instances import Language.Haskell.Brittany.Internal.Utils -import Data.Coerce ( Coercible, coerce ) -import qualified Data.List.NonEmpty as NonEmpty +import Data.Coerce ( Coercible + , coerce + ) +import qualified Data.List.NonEmpty as NonEmpty -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig { _dconf_dump_config = coerce False , _dconf_dump_annotations = coerce False , _dconf_dump_ast_unknown = coerce False @@ -60,62 +64,60 @@ staticDefaultConfig = Config , _dconf_dump_bridoc_final = coerce False , _dconf_roundtrip_exactprint_only = coerce False } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) - , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) + , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = ErrorHandlingConfig + , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False , _econf_Werror = coerce False , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } - , _conf_preprocessor = PreProcessorConfig + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] } --- brittany-next-binding --columns=200 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Option) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! @@ -131,29 +133,24 @@ cmdlineConfigParser = do dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") - dumpBriDocFloating <- addSimpleBoolFlag "" - ["dump-bridoc-floating"] - (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams "" - ["ghc-options"] - "STRING" - (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig + { _conf_version = mempty + , _conf_debug = DebugConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST @@ -167,41 +164,36 @@ cmdlineConfigParser = do , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal , _dconf_roundtrip_exactprint_only = mempty } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty } - , _conf_errorHandling = ErrorHandlingConfig + , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors , _econf_Werror = wrapLast $ falseToNothing wError , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = mempty - , _ppconf_hackAroundIncludes = mempty - } - , _conf_forward = ForwardOptions - { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] - } - , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Option . Bool.bool Nothing (Just True) @@ -265,19 +257,21 @@ userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith Directory.doesFileExist searchDirs "config.yaml" + globalConfig <- Directory.findFileWith Directory.doesFileExist + searchDirs + "config.yaml" maybe (writeUserConfig userBritPathXdg) pure globalConfig - where - writeUserConfig dir = do - let createConfPath = dir FilePath. "config.yaml" - liftIO $ Directory.createDirectoryIfMissing True dir - writeDefaultConfig $ createConfPath - pure createConfPath + where + writeUserConfig dir = do + let createConfPath = dir FilePath. "config.yaml" + liftIO $ Directory.createDirectoryIfMissing True dir + writeDefaultConfig $ createConfPath + pure createConfPath -- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir + let dirParts = FilePath.splitDirectories dir -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" @@ -289,7 +283,8 @@ readConfigs -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let merged = Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + let merged = Semigroup.sconcat + $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs @@ -309,7 +304,6 @@ writeDefaultConfig path = staticDefaultConfig showConfigYaml :: Config -> String -showConfigYaml = Data.ByteString.Char8.unpack - . Data.Yaml.encode - . cMap (\(Identity x) -> Just x) +showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap + (\(Identity x) -> Just x) -- 2.30.2 From f80e777163acfe304ffdfcc209c7872c23a7acfd Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 4 Feb 2020 14:11:45 +0100 Subject: [PATCH 313/478] Allow neat-interpolation-0.4.* --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 53b1b1b..731166f 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -99,7 +99,7 @@ library { , text >=1.2 && <1.3 , multistate >=0.7.1.1 && <0.9 , syb >=0.6 && <0.8 - , neat-interpolation >=0.3.2 && <0.4 + , neat-interpolation >=0.3.2 && <0.5 , data-tree-print , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 -- 2.30.2 From 5895f954bd03dbd1ef067e10b9d5810ab61b276b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 4 Feb 2020 14:14:36 +0100 Subject: [PATCH 314/478] Remove dependency on neat-interpolation --- brittany.cabal | 4 ---- src-literatetests/Main.hs | 2 -- src-unittests/AsymptoticPerfTests.hs | 2 -- src-unittests/TestMain.hs | 2 -- src-unittests/TestUtils.hs | 2 +- 5 files changed, 1 insertion(+), 11 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 6c455ef..bd15eb6 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -100,7 +100,6 @@ library { , text >=1.2 && <1.3 , multistate >=0.7.1.1 && <0.9 , syb >=0.6 && <0.8 - , neat-interpolation >=0.3.2 && <0.5 , data-tree-print , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 @@ -162,7 +161,6 @@ executable brittany , text , multistate , syb - , neat-interpolation , data-tree-print , pretty , bytestring @@ -230,7 +228,6 @@ test-suite unittests , text , multistate , syb - , neat-interpolation , data-tree-print , pretty , bytestring @@ -302,7 +299,6 @@ test-suite littests , text , multistate , syb - , neat-interpolation , data-tree-print , pretty , bytestring diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 19e940a..b733d62 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -16,8 +16,6 @@ import Test.Hspec.Runner ( hspecWith , configConcurrentJobs ) -import NeatInterpolation - import qualified Text.Parsec as Parsec import Text.Parsec.Text ( Parser ) diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs index 778e13a..f3f35ba 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -11,8 +11,6 @@ where import Test.Hspec -import NeatInterpolation - import Language.Haskell.Brittany.Internal import TestUtils diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs index 33a04eb..ca6dbb5 100644 --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -8,8 +8,6 @@ module Main where import Test.Hspec -import NeatInterpolation - import Language.Haskell.Brittany.Internal import AsymptoticPerfTests diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 2e53f67..052ade6 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -8,7 +8,7 @@ module TestUtils where import Test.Hspec -import NeatInterpolation +-- import NeatInterpolation import Language.Haskell.Brittany.Internal -- 2.30.2 From 0fdbd51de04949c6a74d5a7c9ae4d808ca0e086e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 6 Feb 2020 20:28:53 +0100 Subject: [PATCH 315/478] Revert embarrassing debugging leftover that breaks things badly --- src/Language/Haskell/Brittany/Internal.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 7033354..1d9266f 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -474,7 +474,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack - when exactprintOnly $ mTell $ Text.Builder.fromText $ Text.pack "abc" toLocal config' filteredAnns $ do bd <- if exactprintOnly then briDocMToPPM $ briDocByExactNoComment decl -- 2.30.2 From 85d55c376839abf119b821c687b03665ed8a8f60 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 7 Feb 2020 20:03:56 +0100 Subject: [PATCH 316/478] Print paths of files that would change with --check-mode --- src-brittany/Main.hs | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index c064441..77515ce 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -169,6 +169,7 @@ mainCmdParser helpDesc = do (PP.vcat [ PP.text "check for changes but do not write them out" , PP.text "exits with code 0 if no changes necessary, 1 otherwise" + , PP.text "and print file path(s) of files that have changes to stdout" ] ) ) @@ -230,10 +231,9 @@ mainCmdParser helpDesc = do $ trace (showConfigYaml config) $ return () - results <- zipWithM - (coreIO putStrErrLn config (suppressOutput || checkMode)) - inputPaths - outputPaths + results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths if checkMode then when (any (== Changes) (Data.Either.rights results)) @@ -256,10 +256,11 @@ coreIO -> Config -- ^ global program config. -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so -- currently not part of program config. + -> Bool -- ^ whether we are (just) in check mode. -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = +coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = ExceptT.runExceptT $ do let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let ghcOptions = config & _conf_forward & _options_ghc & runIdentity @@ -397,7 +398,8 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str uns@(ErrorUnknownNode{} : _) -> do - putErrorLn $ "WARNING: encountered unknown syntactical constructs:" + putErrorLn + $ "WARNING: encountered unknown syntactical constructs:" uns `forM_` \case ErrorUnknownNode str ast@(L loc _) -> do putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) @@ -410,7 +412,8 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = $ do putErrorLn $ " " ++ show (astToDoc ast) _ -> error "cannot happen (TM)" - putErrorLn " -> falling back on exactprint for this element of the module" + putErrorLn + " -> falling back on exactprint for this element of the module" warns@(LayoutWarning{} : _) -> do putErrorLn $ "WARNINGS:" warns `forM_` \case @@ -443,7 +446,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack - shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) + shouldOutput = + not suppressOutput + && not checkMode + && (not hasErrors || outputOnErrs) when shouldOutput $ addTraceSep (_conf_debug config) @@ -455,6 +461,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText + when (checkMode && hasChanges) $ case inputPathM of + Nothing -> pure () + Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p + when hasErrors $ ExceptT.throwE 70 return (if hasChanges then Changes else NoChanges) where -- 2.30.2 From 825ec425d4092b9c4c1267a9c5d503d01d374cc8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 13 Feb 2020 18:38:18 +0100 Subject: [PATCH 317/478] Improve comments-affecting-layout behaviour for tuples (#231) --- src-literatetests/15-regressions.blt | 22 +++++++++++++++++++ .../Brittany/Internal/LayouterBasics.hs | 20 +++++++++++++++++ .../Brittany/Internal/Layouters/Expr.hs | 5 ++++- 3 files changed, 46 insertions(+), 1 deletion(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index c61bb78..54b467d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -802,3 +802,25 @@ zItazySunefp twgq nlyo lwojjoBiecao = #test module initial comment -- test module MyModule where + +#test issue 231 + +foo = + [ ("xxx", "xx") + , -- + ("xx" , "xx") + -- + , ("xx" , "xxxxx") + , ("xx" , "xx") + ] + +#test issue 231 not + +foo = + [ ("xx", "xx") + , ( "xx" -- + , "xx" + ) + , ("xx", "xxxxx") + , ("xx", "xx") + ] diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 76ec7a3..d40fd6e 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -66,6 +66,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , allocateNode , docSharedWrapper , hasAnyCommentsBelow + , hasCommentsBetween , hasAnyCommentsConnected , hasAnyCommentsPrior , hasAnyRegularCommentsConnected @@ -299,6 +300,25 @@ hasAnyCommentsBelow ast@(L l _) = List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) <$> astConnectedComments ast +hasCommentsBetween + :: Data ast + => GHC.Located ast + -> AnnKeywordId + -> AnnKeywordId + -> ToBriDocM Bool +hasCommentsBetween ast leftKey rightKey = do + mAnn <- astAnn ast + let go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest + case mAnn of + Nothing -> pure False + Just ann -> pure $ go1 $ ExactPrint.annsDP ann + -- | True if there are any comments that are connected to any node below (in AST -- sense) the given node hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 1a02ab8..5a45899 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -528,7 +528,10 @@ layoutExpr lexpr@(L _ expr) = do argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- hasAnyCommentsBelow lexpr + hasComments <- orM + ( hasCommentsBetween lexpr AnnOpenP AnnCloseP + : map hasAnyCommentsBelow args + ) let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") Unboxed -> (docParenHashLSep, docParenHashRSep) -- 2.30.2 From 38cdd152218799b91993e6483903fd5618b7d6d9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 13 Feb 2020 19:03:46 +0100 Subject: [PATCH 318/478] Fix moving comment in export list (haddock header) (#281) --- src-literatetests/15-regressions.blt | 10 +++++++++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 21 ++++++++++++------- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 54b467d..3ae2892 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -824,3 +824,13 @@ foo = , ("xx", "xxxxx") , ("xx", "xx") ] + +#test issue 281 + +module Main + ( DataTypeI + , DataTypeII(DataConstructor) + -- * Haddock heading + , name + ) +where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 0407a3c..f2c36de 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -65,29 +65,36 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of #else IEThingWith x _ ns _ -> do #endif - hasComments <- hasAnyCommentsBelow lie + hasComments <- orM + ( hasCommentsBetween lie AnnOpenP AnnCloseP + : hasAnyCommentsBelow x + : map hasAnyCommentsBelow ns + ) runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR] - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (layoutWrapped lie x) - (layoutItems (splitFirstLast ns)) + addAlternative + $ docWrapNodeRest lie + $ docAddBaseY BrIndentRegular + $ docPar + (layoutWrapped lie x) + (layoutItems (splitFirstLast ns)) where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines - [docSeq [docParenLSep, docWrapNodeRest lie docEmpty], docParenR] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] layoutItems (FirstLast n1 nMs nN) = docSetBaseY $ docLines $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs - ++ [docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN], docParenR] + ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] #if MIN_VERSION_ghc(8,6,0) IEModuleContents _ n -> docSeq #else -- 2.30.2 From a3b501051a2662658ef1ae690ff7a354129f8174 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 23 Feb 2020 23:33:03 +0100 Subject: [PATCH 319/478] Add proper multiline layout for type-level-lists --- src-literatetests/15-regressions.blt | 26 +++++++++++ .../Brittany/Internal/Layouters/Type.hs | 44 ++++++++++++++++++- 2 files changed, 68 insertions(+), 2 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 3ae2892..dbab5b7 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -834,3 +834,29 @@ module Main , name ) where + +#test type level list + +xeoeqibIaib + :: ( KqujhIsaus m + , XivuvIpoboi Droqifim m + , IgorvOtowtf m + , RyagaYaqac m + , QouruDU m + ) + => MaptAdfuxgu + -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd + -> QNOZqwuzg + -> Eoattuq + '[ XkatytdWdquraosu -- test comment + , KyezKijim -- another test comment + , DjmioeePuoeg + , NinrxoiOwezc + , QATAlrijacpk + , TrutvotwIwifiqOjdtu + , CoMmuatjwr + , BoZckzqyodseZole + , VagfwoXaeChfqe + ] + m + () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index bf5a956..940eac7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -14,6 +14,10 @@ where import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Utils + ( splitFirstLast + , FirstLastView(..) + ) import GHC ( runGhc , GenLocated(L) @@ -693,12 +697,48 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsExplicitListTy _ typs -> do #endif typDocs <- docSharedWrapper layoutType `mapM` typs + hasComments <- hasAnyCommentsBelow ltype + let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq $ [docLit $ Text.pack "'["] - ++ List.intersperse docCommaSep typDocs + ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"] - -- TODO + , case splitFirstLast typDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "'[" + , docSeparator + , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e + ] + , docLit $ Text.pack " ]" + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) + ++ [docLit $ Text.pack " ]"] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> + docCols ColList [specialCommaSep, d] + lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype -- 2.30.2 From 4b673d1d9db70e3a0d01a6b3315618e30b887c78 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 25 Feb 2020 17:55:20 +0100 Subject: [PATCH 320/478] Fix bug in record layouting causing overflows --- src-literatetests/15-regressions.blt | 25 +++++++++++++------ .../Brittany/Internal/Layouters/Expr.hs | 2 +- 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index dbab5b7..e4c1b7c 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -363,14 +363,13 @@ samples = (SV.unpackaaaaadat) <&> \f -> #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 - } + let config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } parsePrintModule config text #test recordupd-singleline-bug-left @@ -860,3 +859,13 @@ xeoeqibIaib ] m () + +#test recordupd-overflow-bad-multiline-spacing + +createRedirectedProcess processConfig = do + let redirectedProc = (_processConfig_inner processConfig) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + foo diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 5a45899..bc43fe2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -1226,7 +1226,7 @@ recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do -- } addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep nameDoc + [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc , docSetBaseY $ docLines $ let line1 = docCols ColRec [ appSep $ docLit $ Text.pack "{" -- 2.30.2 From dfa3fef56c0de2539931e0be4049a27b087aab7e Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Tue, 25 Feb 2020 22:04:48 +0000 Subject: [PATCH 321/478] Add support for pattern synonyms --- src-literatetests/14-extensions.blt | 54 ++++++++ .../Brittany/Internal/Layouters/Decl.hs | 128 ++++++++++++++++-- 2 files changed, 171 insertions(+), 11 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 1dc5cf8..9805816 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -82,6 +82,60 @@ import Test ( type (++) , pattern (:.) ) +############################################################################### +## PatternSynonyms +#test bidirectional pattern +{-# LANGUAGE PatternSynonyms #-} +pattern J x = Just x + +#test unidirection pattern +{-# LANGUAGE PatternSynonyms #-} +pattern F x <- (x, _) + +#test explicitly bidirectional pattern +{-# LANGUAGE PatternSynonyms #-} +pattern HeadC x <- x : xs where + HeadC x = [x] + +#test Multiple arguments +{-# LANGUAGE PatternSynonyms #-} +pattern Head2 x y <- x : y : xs where + Head2 x y = [x, y] + +#test Infix argument +{-# LANGUAGE PatternSynonyms #-} +pattern x :> y = [x, y] + +#test Record argument +{-# LANGUAGE PatternSynonyms #-} +pattern MyData { a, b, c } = [a, b, c] + +#test long pattern match +{-# LANGUAGE PatternSynonyms #-} +pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = + [myLongLeftVariableName, myLongRightVariableName] + +#test long explicitly bidirectional match +{-# LANGUAGE PatternSynonyms #-} +pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- + [myLongLeftVariableName, myLongRightVariableName] where + MyInfixPatternMatcher x y = [x, x, y] + +#test Pattern synonym types +{-# LANGUAGE PatternSynonyms #-} +pattern J :: a -> Maybe a +pattern J x = Just x + +#test Pattern synonym type sig wrapped +{-# LANGUAGE PatternSynonyms #-} +pattern LongMatcher + :: longlongtypevar + -> longlongtypevar + -> longlongtypevar + -> Maybe [longlongtypevar] +pattern LongMatcher x y z = Just [x, y, z] + + ############################################################################### ## UnboxedTuples + MagicHash #test unboxed-tuple and vanilla names diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index fbbcafd..265aeb7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -93,11 +93,11 @@ layoutDecl d@(L loc decl) = case decl of layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ - TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ + TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */ - TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ + TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> @@ -121,15 +121,25 @@ layoutSig lsig@(L _loc sig) = case sig of <> nameStr <> Text.pack " #-}" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ - ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ + ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */ - ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ + ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ +#endif +#if MIN_VERSION_ghc(8,6,0) + PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ +#elif MIN_VERSION_ghc(8,2,0) + PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ +#else + PatSynSig name (HsIB _ typ) -> layoutNamesAndType (Just "pattern") [name] typ #endif _ -> briDocByExactNoComment lsig -- TODO where - layoutNamesAndType names typ = docWrapNode lsig $ do + layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do + let keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ @@ -139,8 +149,8 @@ layoutSig lsig@(L _loc sig) = case sig of .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging - then docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr + then docSeq $ + [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] , docSetBaseY $ docLines [ docCols ColTyOpPrefix @@ -151,7 +161,7 @@ layoutSig lsig@(L _loc sig) = case sig of ] else layoutLhsAndType hasComments - (appSep . docWrapNodeRest lsig $ docLit nameStr) + (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) "::" typeDoc @@ -231,8 +241,18 @@ layoutBind lbind@(L _ bind) = case bind of clauseDocs mWhereArg hasComments +#if MIN_VERSION_ghc(8,8,0) + PatSynBind _ (PSB _ patID lpat rpat dir) -> do +#elif MIN_VERSION_ghc(8,6,0) + PatSynBind _ (PSB _ patID lpat rpat dir) -> do +#else + PatSynBind (PSB patID _ lpat rpat dir) -> do +#endif + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID + lpat + dir + rpat _ -> Right <$> unknownNodeError "" lbind - layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -709,6 +729,92 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine +-- | Layout a pattern synonym binding +layoutPatSynBind + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> HsPatSynDir GhcPs + -> LPat GhcPs + -> ToBriDocM BriDocNumbered +layoutPatSynBind name patSynDetails patDir rpat = do + let patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" + mWhereDocs <- layoutPatSynWhere patDir + runFilteredAlternative $ do + addAlternative $ + docLines $ + [ docSeq $ fmap appSep + [ patDoc + , layoutLPatSyn name patSynDetails + , binderDoc, body] + <> case mWhereDocs of + Just _ -> [whereDoc] + Nothing -> [] + ] <> case mWhereDocs of + Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] + Nothing -> [] + + addAlternative $ + docLines $ + [ docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc] + , docEnsureIndent BrIndentRegular . docSeq + $ appSep body : case mWhereDocs of + Just _ -> [whereDoc] + Nothing -> [] + ] <> case mWhereDocs of + Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] + Nothing -> [] + +-- | Helper method for the left hand side of a pattern synonym +layoutLPatSyn + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (PrefixCon vars) = do +#else +layoutLPatSyn name (PrefixPatSyn vars) = do +#endif + docName <- lrdrNameToTextAnn name + names <- mapM lrdrNameToTextAnn vars + docSeq . fmap appSep $ docLit docName : (docLit <$> names) +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (InfixCon left right) = do +#else +layoutLPatSyn name (InfixPatSyn left right) = do +#endif + leftDoc <- lrdrNameToTextAnn left + docName <- lrdrNameToTextAnn name + rightDoc <- lrdrNameToTextAnn right + docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (RecCon recArgs) = do +#else +layoutLPatSyn name (RecordPatSyn recArgs) = do +#endif + docName <- lrdrNameToTextAnn name + args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs + docSeq . fmap docLit + $ [docName, Text.pack " { " ] + <> intersperse (Text.pack ", ") args + <> [Text.pack " }"] + +-- | Helper method to get the where clause from of explicitly bidirectional +-- pattern synonyms +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [BriDocNumbered]) +layoutPatSynWhere hs = case hs of +#if MIN_VERSION_ghc(8,6,0) + ExplicitBidirectional (MG _ (L _ lbinds) _) -> do +#else + ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do +#endif + binderDoc <- docLit $ Text.pack "=" + Just <$> mapM (layoutPatternBind Nothing binderDoc) lbinds + _ -> pure Nothing -------------------------------------------------------------------------------- -- TyClDecl -- 2.30.2 From 9236673d66644ebc8f49e897a7b47bf61214c434 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 13 Mar 2020 01:23:17 +0100 Subject: [PATCH 322/478] Fix newtype indent in associated type family (#207) --- src-literatetests/10-tests.blt | 18 ++++++++++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 1 + 2 files changed, 19 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index a3d1138..88f3598 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1514,6 +1514,24 @@ instance MyClass Int where , intData2 :: Int } +#test instance-with-newtype-family-and-deriving + +{-# LANGUAGE TypeFamilies #-} + +module Lib where + +instance Foo () where + newtype Bar () = Baz () + deriving (Eq, Ord, Show) + bar = Baz + +#test instance-with-newtype-family-and-record + +instance Foo Int where + newtype Bar Int = BarInt + { unBarInt :: Int + } + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index fbbcafd..d457920 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -1037,6 +1037,7 @@ layoutClsInst lcid@(L _ cid) = docLines | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "newtype" `Text.isPrefixOf` t') || (Text.pack "data" `Text.isPrefixOf` t') -- 2.30.2 From 231c2f5e94b2d242de9990f11673e466418a445c Mon Sep 17 00:00:00 2001 From: Neil Mitchell Date: Sat, 14 Mar 2020 16:28:52 +0000 Subject: [PATCH 323/478] Permit extra-1.7 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 731166f..334dacd 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -107,7 +107,7 @@ library { , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.12 , aeson >=1.0.1.0 && <1.5 - , extra >=1.4.10 && <1.7 + , extra >=1.4.10 && <1.8 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 , monad-memo >=0.4.1 && <0.6 -- 2.30.2 From 2d07900005fd3535bcaae91e05cad9dc49be5fb5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:50:42 +0100 Subject: [PATCH 324/478] Rewrite non-recommended usage of docLines --- .../Brittany/Internal/Layouters/Decl.hs | 49 ++++++++++++------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 265aeb7..0f57455 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Decl ( layoutDecl @@ -746,28 +749,38 @@ layoutPatSynBind name patSynDetails patDir rpat = do mWhereDocs <- layoutPatSynWhere patDir runFilteredAlternative $ do addAlternative $ - docLines $ - [ docSeq $ fmap appSep + -- pattern .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docSeq $ [ patDoc + , docSeparator , layoutLPatSyn name patSynDetails - , binderDoc, body] - <> case mWhereDocs of - Just _ -> [whereDoc] + , docSeparator + , binderDoc + , docSeparator + , body + ] ++ case mWhereDocs of + Just ds -> [docSeparator, docPar whereDoc (docSeq ds)] Nothing -> [] - ] <> case mWhereDocs of - Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] - Nothing -> [] addAlternative $ - docLines $ - [ docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc] - , docEnsureIndent BrIndentRegular . docSeq - $ appSep body : case mWhereDocs of - Just _ -> [whereDoc] - Nothing -> [] - ] <> case mWhereDocs of - Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x] + -- pattern .. = + -- .. + -- pattern .. <- + -- .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docPar + (docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc]) + (docLines $ + [ docSeq $ body : case mWhereDocs of + Just _ -> [docSeparator, whereDoc] Nothing -> [] + ] <> case mWhereDocs of + Just x -> [docSeq x] + Nothing -> [] + ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn @@ -805,7 +818,7 @@ layoutLPatSyn name (RecordPatSyn recArgs) = do -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms -layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [BriDocNumbered]) +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of #if MIN_VERSION_ghc(8,6,0) ExplicitBidirectional (MG _ (L _ lbinds) _) -> do @@ -813,7 +826,7 @@ layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do #endif binderDoc <- docLit $ Text.pack "=" - Just <$> mapM (layoutPatternBind Nothing binderDoc) lbinds + Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing -------------------------------------------------------------------------------- -- 2.30.2 From b546b514b00b2141c430c6eebb1fb46a43659637 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:43:45 +0100 Subject: [PATCH 325/478] Add a testcase for PatternSynonym decls (needs fixing) --- src-literatetests/14-extensions.blt | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 9805816..6c97935 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -126,6 +126,26 @@ pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- pattern J :: a -> Maybe a pattern J x = Just x +#test pattern synonym multiple cases +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x + +#test pattern synonym multiple cases with comments +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x -- negative comment + Signed Zero = 0 -- zero comment + Signed (Pos x) = x -- positive comment + +#test Pattern synonym types multiple names +{-# LANGUAGE PatternSynonyms #-} +pattern J, K :: a -> Maybe a + #test Pattern synonym type sig wrapped {-# LANGUAGE PatternSynonyms #-} pattern LongMatcher -- 2.30.2 From eec946830bc12f8a2618692367df799fece77a86 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:58:47 +0100 Subject: [PATCH 326/478] Fix failing testcase on bidirectional pattern synonyms --- .../Brittany/Internal/Layouters/Decl.hs | 30 +++++++++---------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 0f57455..d4f7baa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -753,16 +753,16 @@ layoutPatSynBind name patSynDetails patDir rpat = do -- .. -- .. docAddBaseY BrIndentRegular $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - , docSeparator - , body - ] ++ case mWhereDocs of - Just ds -> [docSeparator, docPar whereDoc (docSeq ds)] - Nothing -> [] + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + , docSeparator + , body + ] ++ case mWhereDocs of + Just ds -> [docSeparator, docPar whereDoc (docLines ds)] + Nothing -> [] addAlternative $ -- pattern .. = @@ -774,12 +774,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do docAddBaseY BrIndentRegular $ docPar (docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc]) (docLines $ - [ docSeq $ body : case mWhereDocs of - Just _ -> [docSeparator, whereDoc] - Nothing -> [] - ] <> case mWhereDocs of - Just x -> [docSeq x] - Nothing -> [] + case mWhereDocs of + Nothing -> [body] + Just ds -> + [ docSeq [body, docSeparator, whereDoc] ] ++ ds ) -- | Helper method for the left hand side of a pattern synonym -- 2.30.2 From 3631f6aec3edcb2c3a80311d128200de81f2504e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 21:59:05 +0100 Subject: [PATCH 327/478] Add another testcase for bidirectional pattern synonyms --- src-literatetests/14-extensions.blt | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 6c97935..d2ec606 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -126,7 +126,7 @@ pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- pattern J :: a -> Maybe a pattern J x = Just x -#test pattern synonym multiple cases +#test pattern synonym bidirectional multiple cases {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} pattern Signed x <- (asSigned -> x) where @@ -134,7 +134,16 @@ pattern Signed x <- (asSigned -> x) where Signed Zero = 0 Signed (Pos x) = x -#test pattern synonym multiple cases with comments +#test pattern synonym bidirectional multiple cases long +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- + (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x + +#test pattern synonym bidirectional multiple cases with comments {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} pattern Signed x <- (asSigned -> x) where -- 2.30.2 From 2ce3fb178c9132d47f422f8e5b91ffcbbfd8c485 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 21 Mar 2020 22:04:34 +0100 Subject: [PATCH 328/478] Share some more bridoc nodes, clean up code --- .../Brittany/Internal/Layouters/Decl.hs | 31 +++++++++---------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index d4f7baa..9394ebd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -747,23 +747,24 @@ layoutPatSynBind name patSynDetails patDir rpat = do body = colsWrapPat =<< layoutPat rpat whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir + headDoc <- fmap pure $ docSeq $ + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] runFilteredAlternative $ do addAlternative $ -- pattern .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - , docSeparator - , body - ] ++ case mWhereDocs of + docAddBaseY BrIndentRegular $ docSeq + ( [headDoc, docSeparator, body] + ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] - + ) addAlternative $ -- pattern .. = -- .. @@ -772,12 +773,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do -- .. -- .. docAddBaseY BrIndentRegular $ docPar - (docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc]) - (docLines $ - case mWhereDocs of - Nothing -> [body] - Just ds -> - [ docSeq [body, docSeparator, whereDoc] ] ++ ds + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) ) -- | Helper method for the left hand side of a pattern synonym -- 2.30.2 From ae0e397fac76c0c2118ba59981c522845d22672e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 22 Mar 2020 22:44:13 +0100 Subject: [PATCH 329/478] Disable one test-case for ghc-8.0 (unsupported syntax) --- src-literatetests/14-extensions.blt | 1 + 1 file changed, 1 insertion(+) diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index d2ec606..81dde02 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -152,6 +152,7 @@ pattern Signed x <- (asSigned -> x) where Signed (Pos x) = x -- positive comment #test Pattern synonym types multiple names +#min-ghc 8.2 {-# LANGUAGE PatternSynonyms #-} pattern J, K :: a -> Maybe a -- 2.30.2 From df2ee177b29bebc06700e21cc5d8778037f659ff Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 23 Feb 2020 23:09:03 +0100 Subject: [PATCH 330/478] Fix comments in instance/type instances (#282) --- src-literatetests/15-regressions.blt | 8 +++ .../Brittany/Internal/Layouters/Decl.hs | 59 +++++++++---------- 2 files changed, 37 insertions(+), 30 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index e4c1b7c..a6a0274 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -869,3 +869,11 @@ createRedirectedProcess processConfig = do , std_err = CreatePipe } foo + +#test issue 282 + +instance HasDependencies SomeDataModel where + -- N.B. Here is a bunch of explanatory context about the relationship + -- between these data models or whatever. + type Dependencies SomeDataModel + = (SomeOtherDataModelId, SomeOtherOtherDataModelId) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index e6466ac..13d0853 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -72,7 +72,7 @@ layoutDecl d@(L loc decl) = case decl of Right n -> return n TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d @@ -84,7 +84,7 @@ layoutDecl d@(L loc decl) = case decl of Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #endif @@ -941,39 +941,39 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do -layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl -layoutTyFamInstDecl inClass (L loc tfid) = do +layoutTyFamInstDecl + :: Data.Data.Data a + => Bool + -> Located a + -> TyFamInstDecl GhcPs + -> ToBriDocM BriDocNumbered +layoutTyFamInstDecl inClass outerNode tfid = do let #if MIN_VERSION_ghc(8,8,0) - linst = L loc (TyFamInstD NoExt tfid) - feqn@(FamEqn _ name bndrsMay pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,6,0) - linst = L loc (TyFamInstD NoExt tfid) - feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,4,0) - linst = L loc (TyFamInstD tfid) - feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,2,0) - linst = L loc (TyFamInstD tfid) - lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid + innerNode@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #else - linst = L loc (TyFamInstD tfid) - lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid + innerNode@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #endif - docWrapNodePrior linst $ do + docWrapNodePrior outerNode $ do nameStr <- lrdrNameToTextAnn name - needsParens <- hasAnnKeyword lfeqn AnnOpenP + needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass then docLit $ Text.pack "type" @@ -987,9 +987,7 @@ layoutTyFamInstDecl inClass (L loc tfid) = do ++ processTyVarBndrsSingleline bndrDocs ) lhs = - docWrapNode lfeqn - . appSep - . docWrapNodeRest linst + docWrapNode innerNode . docSeq $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] @@ -998,8 +996,8 @@ layoutTyFamInstDecl inClass (L loc tfid) = do ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] hasComments <- (||) - <$> hasAnyRegularCommentsConnected lfeqn - <*> hasAnyRegularCommentsRest linst + <$> hasAnyRegularCommentsConnected outerNode + <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc @@ -1085,8 +1083,8 @@ layoutClsInst lcid@(L _ cid) = docLines layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateTyFamInsts ltfid@(L loc _) = - L loc <$> layoutTyFamInstDecl True ltfid + layoutAndLocateTyFamInsts ltfid@(L loc tfid) = + L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) @@ -1168,13 +1166,12 @@ layoutLhsAndType -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered layoutLhsAndType hasComments lhs sep typeDoc = do - let sepDoc = appSep . docLit $ Text.pack sep runFilteredAlternative $ do -- (separators probably are "=" or "::") -- lhs = type -- lhs :: type - addAlternativeCond (not hasComments) - $ docSeq [lhs, sepDoc, docForceSingleline typeDoc] + addAlternativeCond (not hasComments) $ docSeq + [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB @@ -1183,4 +1180,6 @@ layoutLhsAndType hasComments lhs sep typeDoc = do -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix - [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] + [ appSep $ docLitS sep + , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc + ] -- 2.30.2 From 061c39b4e9c41bdb23ca4eab302001fafbef50bf Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Mar 2020 23:32:10 +0100 Subject: [PATCH 331/478] Fix a semi-hidden missing indentation bug --- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 4 +++- src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs | 5 ++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index e6466ac..9022613 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -534,7 +534,9 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] ] ] ++ wherePartMultiLine diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 3fd5f8a..3aa3b5c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -51,7 +51,10 @@ layoutStmt lstmt@(L _ stmt) = do [ docCols ColBindStmt [ appSep patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] + , docSeq + [ appSep $ docLit $ Text.pack "<-" + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc + ] ] , docCols ColBindStmt -- 2.30.2 From 8778dcf2f4ffb0a3017dff766e7fbe7d649b812e Mon Sep 17 00:00:00 2001 From: Soares Chen Date: Mon, 6 Apr 2020 10:21:38 +0000 Subject: [PATCH 332/478] Create Main module for Brittany --- brittany.cabal | 61 +--- src-brittany/Main.hs | 482 +------------------------ src/Language/Haskell/Brittany/Main.hs | 484 ++++++++++++++++++++++++++ 3 files changed, 493 insertions(+), 534 deletions(-) create mode 100644 src/Language/Haskell/Brittany/Main.hs diff --git a/brittany.cabal b/brittany.cabal index a4e0c76..0bd1271 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,3 +1,4 @@ +cabal-version: 2.2 name: brittany version: 0.12.1.1 synopsis: Haskell source code formatter @@ -8,7 +9,7 @@ description: { . The implementation is documented in more detail . } -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner @@ -16,7 +17,6 @@ copyright: Copyright (C) 2016-2019 Lennart Spitzner Copyright (C) 2019 PRODA LTD category: Language build-type: Simple -cabal-version: 1.18 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues extra-doc-files: { @@ -53,6 +53,7 @@ library { srcinc exposed-modules: { Language.Haskell.Brittany + Language.Haskell.Brittany.Main Language.Haskell.Brittany.Internal Language.Haskell.Brittany.Internal.Prelude Language.Haskell.Brittany.Internal.PreludeUtils @@ -145,60 +146,12 @@ executable brittany buildable: True } main-is: Main.hs - other-modules: { - Paths_brittany - } - -- other-extensions: - build-depends: - { brittany - , base - , ghc - , ghc-paths - , ghc-exactprint - , transformers - , containers - , mtl - , text - , multistate - , syb - , data-tree-print - , pretty - , bytestring - , directory - , butcher - , yaml - , aeson - , extra - , uniplate - , strict - , monad-memo - , unsafe - , safe - , deepseq - , semigroups - , cmdargs - , czipwith - , ghc-boot-th - , filepath >=1.4.1.0 && <1.5 - } hs-source-dirs: src-brittany - include-dirs: srcinc + build-depends: + { base + , brittany + } default-language: Haskell2010 - default-extensions: { - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } ghc-options: { -Wall -fno-spec-constr diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 77515ce..0312f6b 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -1,484 +1,6 @@ -{-# LANGUAGE DataKinds #-} - module Main where - - -#include "prelude.inc" - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate - as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Data.Map as Map -import qualified Data.Monoid - -import GHC ( GenLocated(L) ) -import Outputable ( Outputable(..) - , showSDocUnsafe - ) - -import Text.Read ( Read(..) ) -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Control.Monad ( zipWithM ) -import Data.CZipWith - -import qualified Debug.Trace as Trace - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Obfuscation - -import qualified Text.PrettyPrint as PP - -import DataTreePrint -import UI.Butcher.Monadic - -import qualified System.Exit -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Paths_brittany - - - -data WriteMode = Display | Inplace - -instance Read WriteMode where - readPrec = val "display" Display <|> val "inplace" Inplace - where val iden v = ReadPrec.lift $ ReadP.string iden >> return v - -instance Show WriteMode where - show Display = "display" - show Inplace = "inplace" - +import qualified Language.Haskell.Brittany.Main as BrittanyMain main :: IO () -main = mainFromCmdParserWithHelpDesc mainCmdParser - -helpDoc :: PP.Doc -helpDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDocW - [ "Reformats one or more haskell modules." - , "Currently affects only the module head (imports/exports), type" - , "signatures and function bindings;" - , "everything else is left unmodified." - , "Based on ghc-exactprint, thus (theoretically) supporting all" - , "that ghc does." - ] - , parDoc $ "Example invocations:" - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany" - , PP.nest 2 $ PP.text "read from stdin, output to stdout" - ] - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" - , PP.nest 2 $ PP.vcat - [ PP.text "run on all modules in current directory (no backup!)" - , PP.text "4 spaces indentation" - ] - ] - , parDocW - [ "This program is written carefully and contains safeguards to ensure" - , "the output is syntactically valid and that no comments are removed." - , "Nonetheless, this is a young project, and there will always be bugs," - , "and ensuring that the transformation never changes semantics of the" - , "transformed source is currently not possible." - , "Please do check the output and do not let brittany override your large" - , "codebase without having backups." - ] - , parDoc $ "There is NO WARRANTY, to the extent permitted by law." - , parDocW - [ "This program is free software released under the AGPLv3." - , "For details use the --license flag." - ] - , parDoc $ "See https://github.com/lspitzner/brittany" - , parDoc - $ "Please report bugs at" - ++ " https://github.com/lspitzner/brittany/issues" - ] - -licenseDoc :: PP.Doc -licenseDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" - , parDoc $ "Copyright (C) 2019 PRODA LTD" - , parDocW - [ "This program is free software: you can redistribute it and/or modify" - , "it under the terms of the GNU Affero General Public License," - , "version 3, as published by the Free Software Foundation." - ] - , parDocW - [ "This program is distributed in the hope that it will be useful," - , "but WITHOUT ANY WARRANTY; without even the implied warranty of" - , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , "GNU Affero General Public License for more details." - ] - , parDocW - [ "You should have received a copy of the GNU Affero General Public" - , "License along with this program. If not, see" - , "." - ] - ] - - -mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () -mainCmdParser helpDesc = do - addCmdSynopsis "haskell source pretty printer" - addCmdHelp $ helpDoc - -- addCmd "debugArgs" $ do - addHelpCommand helpDesc - addCmd "license" $ addCmdImpl $ print $ licenseDoc - -- addButcherDebugCommand - reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser - suppressOutput <- addSimpleBoolFlag - "" - ["suppress-output"] - (flagHelp $ parDoc - "suppress the regular output, i.e. the transformed haskell source" - ) - _verbosity <- addSimpleCountFlag - "v" - ["verbose"] - (flagHelp $ parDoc "[currently without effect; TODO]") - checkMode <- addSimpleBoolFlag - "c" - ["check-mode"] - (flagHelp - (PP.vcat - [ PP.text "check for changes but do not write them out" - , PP.text "exits with code 0 if no changes necessary, 1 otherwise" - , PP.text "and print file path(s) of files that have changes to stdout" - ] - ) - ) - writeMode <- addFlagReadParam - "" - ["write-mode"] - "(display|inplace)" - ( flagHelp - (PP.vcat - [ PP.text "display: output for any input(s) goes to stdout" - , PP.text "inplace: override respective input file (without backup!)" - ] - ) - Data.Monoid.<> flagDefault Display - ) - inputParams <- addParamNoFlagStrings - "PATH" - (paramHelpStr "paths to input/inout haskell source files") - reorderStop - addCmdImpl $ void $ do - when printLicense $ do - print licenseDoc - System.Exit.exitSuccess - when printVersion $ do - do - putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" - putStrLn $ "Copyright (C) 2019 PRODA LTD" - putStrLn $ "There is NO WARRANTY, to the extent permitted by law." - System.Exit.exitSuccess - when printHelp $ do - liftIO - $ putStrLn - $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } - $ ppHelpShallow helpDesc - System.Exit.exitSuccess - - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths - - configsToLoad <- liftIO $ if null configPaths - then - maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths - - config <- - runMaybeT - (if noUserConfig - then readConfigs cmdlineConfig configsToLoad - else readConfigsWithUserConfig cmdlineConfig configsToLoad - ) - >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x - when (config & _conf_debug & _dconf_dump_config & confUnpack) - $ trace (showConfigYaml config) - $ return () - - results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths - - if checkMode - then when (any (== Changes) (Data.Either.rights results)) - $ System.Exit.exitWith (System.Exit.ExitFailure 1) - else case results of - xs | all Data.Either.isRight xs -> pure () - [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) - - -data ChangeStatus = Changes | NoChanges - deriving (Eq) - --- | The main IO parts for the default mode of operation, and after commandline --- and config stuff is processed. -coreIO - :: (String -> IO ()) -- ^ error output function. In parallel operation, you - -- may want serialize the different outputs and - -- consequently not directly print to stderr. - -> Config -- ^ global program config. - -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so - -- currently not part of program config. - -> Bool -- ^ whether we are (just) in check mode. - -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. - -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. - -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = - ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - -- there is a good of code duplication between the following code and the - -- `pureModuleTransform` function. Unfortunately, there are also a good - -- amount of slight differences: This module is a bit more verbose, and - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- the flag will do the following: insert a marker string - -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - -- The flag is intentionally misspelled to prevent clashing with - -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - (parseResult, originalContents) <- case inputPathM of - Nothing -> do - -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id - inputString <- liftIO $ System.IO.hGetContents System.IO.stdin - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) - return (parseRes, Text.pack inputString) - Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc - inputText <- Text.IO.readFile p - -- The above means we read the file twice, but the - -- GHC API does not really expose the source it - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> - -- handle still open -> write below crashes - evil.) - return (parseRes, inputText) - case parseResult of - Left left -> do - putErrorLn "parse error:" - putErrorLn left - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - of - Left (err, input) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - ExceptT.throwE 61 - Right c -> -- trace (showTree c) $ - pure c - let moduleConf = cZipWith fromOptionIdentity config inlineConf - when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - let disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack - (errsWarns, outSText, hasChanges) <- do - if - | disableFormatting -> do - pure ([], originalContents, False) - | exactprintOnly -> do - let r = Text.pack $ ExactPrint.exactPrint parsedSource anns - pure ([], r, r /= originalContents) - | otherwise -> do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return - $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ fmap hackF - $ TextL.splitOn (TextL.pack "\n") outRaw - else outRaw - out' <- if moduleConf & _conf_obfuscate & confUnpack - then lift $ obfuscate out - else pure out - pure $ (ews, out', out' /= originalContents) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 - when (not $ null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{} : _) -> do - putErrorLn - $ "ERROR: brittany pretty printer" - ++ " returned syntactically invalid result." - (ErrorInput str : _) -> do - putErrorLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{} : _) -> do - putErrorLn - $ "WARNING: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) - when - ( config - & _conf_debug - & _dconf_dump_ast_unknown - & confUnpack - ) - $ do - putErrorLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - putErrorLn - " -> falling back on exactprint for this element of the module" - warns@(LayoutWarning{} : _) -> do - putErrorLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{} : _) -> do - putErrorLn - $ "Error: detected unprocessed comments." - ++ " The transformation output will most likely" - ++ " not contain some of the comments" - ++ " present in the input haskell source file." - putErrorLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" - (ErrorMacroConfig err input : _) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - [] -> error "cannot happen" - -- TODO: don't output anything when there are errors unless user - -- adds some override? - let - hasErrors = - case config & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - outputOnErrs = - config - & _conf_errorHandling - & _econf_produceOutputOnErrors - & confUnpack - shouldOutput = - not suppressOutput - && not checkMode - && (not hasErrors || outputOnErrs) - - when shouldOutput - $ addTraceSep (_conf_debug config) - $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges - unless isIdentical $ Text.IO.writeFile p $ outSText - - when (checkMode && hasChanges) $ case inputPathM of - Nothing -> pure () - Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p - - when hasErrors $ ExceptT.throwE 70 - return (if hasChanges then Changes else NoChanges) - where - addTraceSep conf = - if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] - then trace "----" - else id +main = BrittanyMain.main diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs new file mode 100644 index 0000000..c2f2254 --- /dev/null +++ b/src/Language/Haskell/Brittany/Main.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Main (main) where + + + +#include "prelude.inc" + +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate + as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Data.Map as Map +import qualified Data.Monoid + +import GHC ( GenLocated(L) ) +import Outputable ( Outputable(..) + , showSDocUnsafe + ) + +import Text.Read ( Read(..) ) +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Control.Monad ( zipWithM ) +import Data.CZipWith + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Obfuscation + +import qualified Text.PrettyPrint as PP + +import DataTreePrint +import UI.Butcher.Monadic + +import qualified System.Exit +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Paths_brittany + + + +data WriteMode = Display | Inplace + +instance Read WriteMode where + readPrec = val "display" Display <|> val "inplace" Inplace + where val iden v = ReadPrec.lift $ ReadP.string iden >> return v + +instance Show WriteMode where + show Display = "display" + show Inplace = "inplace" + + +main :: IO () +main = mainFromCmdParserWithHelpDesc mainCmdParser + +helpDoc :: PP.Doc +helpDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDocW + [ "Reformats one or more haskell modules." + , "Currently affects only the module head (imports/exports), type" + , "signatures and function bindings;" + , "everything else is left unmodified." + , "Based on ghc-exactprint, thus (theoretically) supporting all" + , "that ghc does." + ] + , parDoc $ "Example invocations:" + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany" + , PP.nest 2 $ PP.text "read from stdin, output to stdout" + ] + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" + , PP.nest 2 $ PP.vcat + [ PP.text "run on all modules in current directory (no backup!)" + , PP.text "4 spaces indentation" + ] + ] + , parDocW + [ "This program is written carefully and contains safeguards to ensure" + , "the output is syntactically valid and that no comments are removed." + , "Nonetheless, this is a young project, and there will always be bugs," + , "and ensuring that the transformation never changes semantics of the" + , "transformed source is currently not possible." + , "Please do check the output and do not let brittany override your large" + , "codebase without having backups." + ] + , parDoc $ "There is NO WARRANTY, to the extent permitted by law." + , parDocW + [ "This program is free software released under the AGPLv3." + , "For details use the --license flag." + ] + , parDoc $ "See https://github.com/lspitzner/brittany" + , parDoc + $ "Please report bugs at" + ++ " https://github.com/lspitzner/brittany/issues" + ] + +licenseDoc :: PP.Doc +licenseDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" + , parDoc $ "Copyright (C) 2019 PRODA LTD" + , parDocW + [ "This program is free software: you can redistribute it and/or modify" + , "it under the terms of the GNU Affero General Public License," + , "version 3, as published by the Free Software Foundation." + ] + , parDocW + [ "This program is distributed in the hope that it will be useful," + , "but WITHOUT ANY WARRANTY; without even the implied warranty of" + , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , "GNU Affero General Public License for more details." + ] + , parDocW + [ "You should have received a copy of the GNU Affero General Public" + , "License along with this program. If not, see" + , "." + ] + ] + + +mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () +mainCmdParser helpDesc = do + addCmdSynopsis "haskell source pretty printer" + addCmdHelp $ helpDoc + -- addCmd "debugArgs" $ do + addHelpCommand helpDesc + addCmd "license" $ addCmdImpl $ print $ licenseDoc + -- addButcherDebugCommand + reorderStart + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] mempty + noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty + configPaths <- addFlagStringParams "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser + suppressOutput <- addSimpleBoolFlag + "" + ["suppress-output"] + (flagHelp $ parDoc + "suppress the regular output, i.e. the transformed haskell source" + ) + _verbosity <- addSimpleCountFlag + "v" + ["verbose"] + (flagHelp $ parDoc "[currently without effect; TODO]") + checkMode <- addSimpleBoolFlag + "c" + ["check-mode"] + (flagHelp + (PP.vcat + [ PP.text "check for changes but do not write them out" + , PP.text "exits with code 0 if no changes necessary, 1 otherwise" + , PP.text "and print file path(s) of files that have changes to stdout" + ] + ) + ) + writeMode <- addFlagReadParam + "" + ["write-mode"] + "(display|inplace)" + ( flagHelp + (PP.vcat + [ PP.text "display: output for any input(s) goes to stdout" + , PP.text "inplace: override respective input file (without backup!)" + ] + ) + Data.Monoid.<> flagDefault Display + ) + inputParams <- addParamNoFlagStrings + "PATH" + (paramHelpStr "paths to input/inout haskell source files") + reorderStop + addCmdImpl $ void $ do + when printLicense $ do + print licenseDoc + System.Exit.exitSuccess + when printVersion $ do + do + putStrLn $ "brittany version " ++ showVersion version + putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" + putStrLn $ "Copyright (C) 2019 PRODA LTD" + putStrLn $ "There is NO WARRANTY, to the extent permitted by law." + System.Exit.exitSuccess + when printHelp $ do + liftIO + $ putStrLn + $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } + $ ppHelpShallow helpDesc + System.Exit.exitSuccess + + let inputPaths = + if null inputParams then [Nothing] else map Just inputParams + let outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths + + configsToLoad <- liftIO $ if null configPaths + then + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- + runMaybeT + (if noUserConfig + then readConfigs cmdlineConfig configsToLoad + else readConfigsWithUserConfig cmdlineConfig configsToLoad + ) + >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + when (config & _conf_debug & _dconf_dump_config & confUnpack) + $ trace (showConfigYaml config) + $ return () + + results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths + + if checkMode + then when (any (== Changes) (Data.Either.rights results)) + $ System.Exit.exitWith (System.Exit.ExitFailure 1) + else case results of + xs | all Data.Either.isRight xs -> pure () + [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + + +data ChangeStatus = Changes | NoChanges + deriving (Eq) + +-- | The main IO parts for the default mode of operation, and after commandline +-- and config stuff is processed. +coreIO + :: (String -> IO ()) -- ^ error output function. In parallel operation, you + -- may want serialize the different outputs and + -- consequently not directly print to stderr. + -> Config -- ^ global program config. + -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so + -- currently not part of program config. + -> Bool -- ^ whether we are (just) in check mode. + -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. + -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. + -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. +coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = + ExceptT.runExceptT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + -- there is a good of code duplication between the following code and the + -- `pureModuleTransform` function. Unfortunately, there are also a good + -- amount of slight differences: This module is a bit more verbose, and + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- the flag will do the following: insert a marker string + -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + -- The flag is intentionally misspelled to prevent clashing with + -- inline-config stuff. + let hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + (parseResult, originalContents) <- case inputPathM of + Nothing -> do + -- TODO: refactor this hack to not be mixed into parsing logic + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id + inputString <- liftIO $ System.IO.hGetContents System.IO.stdin + parseRes <- liftIO $ parseModuleFromString ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) + return (parseRes, Text.pack inputString) + Just p -> liftIO $ do + parseRes <- parseModule ghcOptions p cppCheckFunc + inputText <- Text.IO.readFile p + -- The above means we read the file twice, but the + -- GHC API does not really expose the source it + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> + -- handle still open -> write below crashes - evil.) + return (parseRes, inputText) + case parseResult of + Left left -> do + putErrorLn "parse error:" + putErrorLn left + ExceptT.throwE 60 + Right (anns, parsedSource, hasCPP) -> do + (inlineConf, perItemConf) <- + case + extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + of + Left (err, input) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + ExceptT.throwE 61 + Right c -> -- trace (showTree c) $ + pure c + let moduleConf = cZipWith fromOptionIdentity config inlineConf + when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + let disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack + (errsWarns, outSText, hasChanges) <- do + if + | disableFormatting -> do + pure ([], originalContents, False) + | exactprintOnly -> do + let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + pure ([], r, r /= originalContents) + | otherwise -> do + let omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return + $ pPrintModule moduleConf perItemConf anns parsedSource + else liftIO $ pPrintModuleAndCheck moduleConf + perItemConf + anns + parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ fmap hackF + $ TextL.splitOn (TextL.pack "\n") outRaw + else outRaw + out' <- if moduleConf & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out', out' /= originalContents) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 + when (not $ null errsWarns) $ do + let groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns + groupedErrsWarns `forM_` \case + (ErrorOutputCheck{} : _) -> do + putErrorLn + $ "ERROR: brittany pretty printer" + ++ " returned syntactically invalid result." + (ErrorInput str : _) -> do + putErrorLn $ "ERROR: parse error: " ++ str + uns@(ErrorUnknownNode{} : _) -> do + putErrorLn + $ "WARNING: encountered unknown syntactical constructs:" + uns `forM_` \case + ErrorUnknownNode str ast@(L loc _) -> do + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) + when + ( config + & _conf_debug + & _dconf_dump_ast_unknown + & confUnpack + ) + $ do + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + putErrorLn + " -> falling back on exactprint for this element of the module" + warns@(LayoutWarning{} : _) -> do + putErrorLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putErrorLn str + _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComment{} : _) -> do + putErrorLn + $ "Error: detected unprocessed comments." + ++ " The transformation output will most likely" + ++ " not contain some of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> error "cannot happen (TM)" + (ErrorMacroConfig err input : _) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let + hasErrors = + case config & _conf_errorHandling & _econf_Werror & confUnpack of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + outputOnErrs = + config + & _conf_errorHandling + & _econf_produceOutputOnErrors + & confUnpack + shouldOutput = + not suppressOutput + && not checkMode + && (not hasErrors || outputOnErrs) + + when shouldOutput + $ addTraceSep (_conf_debug config) + $ case outputPathM of + Nothing -> liftIO $ Text.IO.putStr $ outSText + Just p -> liftIO $ do + let isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges + unless isIdentical $ Text.IO.writeFile p $ outSText + + when (checkMode && hasChanges) $ case inputPathM of + Nothing -> pure () + Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p + + when hasErrors $ ExceptT.throwE 70 + return (if hasChanges then Changes else NoChanges) + where + addTraceSep conf = + if or + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] + then trace "----" + else id -- 2.30.2 From 5c64928972c6bed09ae6d44be4070114b595335e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 21 Apr 2020 01:34:31 +0200 Subject: [PATCH 333/478] Fix problem of do notation as left argument of an operator --- src-literatetests/15-regressions.blt | 7 ++++ .../Brittany/Internal/Layouters/Expr.hs | 34 +++++++++++-------- 2 files changed, 27 insertions(+), 14 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index a6a0274..7fa47e0 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -877,3 +877,10 @@ instance HasDependencies SomeDataModel where -- between these data models or whatever. type Dependencies SomeDataModel = (SomeOtherDataModelId, SomeOtherOtherDataModelId) + +#test stupid-do-operator-combination + +func = + do + y + >>= x diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index bc43fe2..660355c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -426,6 +426,9 @@ layoutExpr lexpr@(L _ expr) = do (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True #endif + let leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line addAlternative @@ -442,16 +445,17 @@ layoutExpr lexpr@(L _ expr) = do -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight -- ] -- two-line - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft -- TODO: this is not forced to single-line, which has - -- certain.. interesting consequences. - -- At least, the "two-line" label is not entirely - -- accurate. - ( docForceSingleline + addAlternative $ do + let + expDocOpAndRight = docForceSingleline $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - ) + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight + -- TODO: in both cases, we don't force expDocLeft to be + -- single-line, which has certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. -- one-line + par addAlternativeCond allowPar $ docSeq @@ -460,11 +464,13 @@ layoutExpr lexpr@(L _ expr) = do , docForceParSpacing expDocRight ] -- more lines - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]) + addAlternative $ do + let expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ NegApp _ op _ -> do #else -- 2.30.2 From 8c57372bde1f108d8cd8acc79aef0c631ffcbd46 Mon Sep 17 00:00:00 2001 From: Andy Date: Tue, 5 May 2020 10:46:59 +0200 Subject: [PATCH 334/478] Readme: Supports 8.8 --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index df7b22e..6fe5976 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`. +- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`, `8.8`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. -- 2.30.2 From 2da8bd5e74c0e0dfff1e5dc65d7d3cc145667388 Mon Sep 17 00:00:00 2001 From: Soares Chen Date: Wed, 6 May 2020 13:37:03 +0200 Subject: [PATCH 335/478] Revert change to cabal version --- brittany.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 0bd1271..d99ad17 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,4 +1,3 @@ -cabal-version: 2.2 name: brittany version: 0.12.1.1 synopsis: Haskell source code formatter @@ -9,7 +8,7 @@ description: { . The implementation is documented in more detail . } -license: AGPL-3.0-only +license: AGPL-3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner @@ -17,6 +16,7 @@ copyright: Copyright (C) 2016-2019 Lennart Spitzner Copyright (C) 2019 PRODA LTD category: Language build-type: Simple +cabal-version: 1.18 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues extra-doc-files: { -- 2.30.2 From 9b8ed90a8fd10dcefb06221691c87886504de46c Mon Sep 17 00:00:00 2001 From: Joe Kachmar Date: Mon, 20 Jul 2020 22:44:02 -0400 Subject: [PATCH 336/478] Allows aeson-1.5.* --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index d99ad17..dc0e796 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -107,7 +107,7 @@ library { , directory >=1.2.6.2 && <1.4 , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.12 - , aeson >=1.0.1.0 && <1.5 + , aeson >=1.0.1.0 && <1.6 , extra >=1.4.10 && <1.8 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 -- 2.30.2 From 64417c59f4ecb8233b309f69726538325bdc6854 Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Sun, 22 Mar 2020 13:06:04 +0800 Subject: [PATCH 337/478] nondecreasing export list formatting --- src-literatetests/10-tests.blt | 11 ++++------- src-literatetests/15-regressions.blt | 3 +-- src-literatetests/30-tests-context-free.blt | 9 +++------ .../Haskell/Brittany/Internal/Layouters/Module.hs | 11 +++++++---- 4 files changed, 15 insertions(+), 19 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index a3d1138..be8ce52 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1001,8 +1001,7 @@ module Main , test7 , test8 , test9 - ) -where + ) where #test exports-with-comments module Main @@ -1016,8 +1015,7 @@ module Main -- Test 5 , test5 -- Test 6 - ) -where + ) where #test simple-export-with-things module Main (Test(..)) where @@ -1035,7 +1033,7 @@ module Main ( Test(Test, a, b) , foo -- comment2 ) -- comment3 -where + where #test export-with-empty-thing module Main (Test()) where @@ -1286,8 +1284,7 @@ module Test , test9 , test10 -- Test 10 - ) -where + ) where -- Test import Data.List ( nub ) -- Test diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index e4c1b7c..e09e41b 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -831,8 +831,7 @@ module Main , DataTypeII(DataConstructor) -- * Haddock heading , name - ) -where + ) where #test type level list diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index ba84a7c..18649a1 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -675,8 +675,7 @@ module Main , test7 , test8 , test9 - ) -where + ) where #test exports-with-comments module Main @@ -690,8 +689,7 @@ module Main -- Test 5 , test5 -- Test 6 - ) -where + ) where #test simple-export-with-things module Main (Test(..)) where @@ -913,8 +911,7 @@ module Test , test8 , test9 , test10 - ) -where + ) where -- Test import Data.List (nub) -- Test diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index cb82c75..f899e08 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -49,6 +49,7 @@ layoutModule lmod@(L _ mod') = case mod' of , docWrapNode lmod $ appSep $ case les of Nothing -> docEmpty Just x -> layoutLLIEs True x + , docSeparator , docLit $ Text.pack "where" ] addAlternative @@ -56,11 +57,13 @@ layoutModule lmod@(L _ mod') = case mod' of [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) - (docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False x + (docSeq [ docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + , docSeparator + , docLit $ Text.pack "where" + ] ) - , docLit $ Text.pack "where" ] ] : map layoutImport imports -- 2.30.2 From 8e168f1578bb695a0ceab038dc3cb3fd52570589 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 08:23:03 -0500 Subject: [PATCH 338/478] Update stack.yaml.lock --- stack.yaml.lock | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index 6b3c445..6a1ae68 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -33,12 +33,12 @@ packages: original: hackage: strict-list-0.1.4 - completed: - hackage: ghc-exactprint-0.5.8.2@sha256:b078e02ce263db6214f8418c8b6f6be1c8a7ca1499bb2f8936b91b5ed210faa5,7901 + hackage: ghc-exactprint-0.6.2@sha256:d822f64351e9a8e03d9bad35c8fdf558d30dc396801b396c52b5d5bffaee9108,8368 pantry-tree: - size: 83871 - sha256: 1dc1dc7f036dfb8e7642deaeb2845c62731085abc29a1494c22cd6b1b5a18d16 + size: 85384 + sha256: d904de9c01e58bfa091d7caa09e0423e9d2932b7b3490c4d83140731f4473877 original: - hackage: ghc-exactprint-0.5.8.2 + hackage: ghc-exactprint-0.6.2 snapshots: - completed: size: 499461 -- 2.30.2 From d5a5bec7297c4b84b3d5a2bdb045f194a36e3ea8 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 08:28:00 -0500 Subject: [PATCH 339/478] Start setting up GitHub Actions --- .github/workflows/ci.yaml | 42 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 .github/workflows/ci.yaml diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml new file mode 100644 index 0000000..bc63b06 --- /dev/null +++ b/.github/workflows/ci.yaml @@ -0,0 +1,42 @@ +name: CI +on: + pull_request: + branches: + - master + push: + branches: + - master +jobs: + build: + strategy: + matrix: + os: + - ubuntu-18.04 + ghc: + - 8.8.4 + cabal: + - 3.2.0.0 + runs-on: ${{ matrix.os }} + steps: + - uses: actions/checkout@v2 + - id: setup-haskell + uses: actions/setup-haskell@v1 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + - run: cabal freeze + - run: cat cabal.project.freeze + - uses: actions/cache@v2 + with: + path: ${{ steps.setup-haskell.outputs.cabal-store }} + key: ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-${{ hashFiles('cabal.project.freeze') }} + restore-keys: | + ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}- + ${{ matrix.os }}-${{ matrix.ghc }}- + - run: cabal test --test-show-details direct + - run: cabal sdist + - uses: actions/upload-artifact@v2 + with: + path: dist-newstyle/sdist/brittany-*.tar.gz + name: brittany-${{ github.sha }}.tar.gz + - run: cabal check -- 2.30.2 From e88872994b73fb9409d0986a7340b2f6022cc384 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 08:41:43 -0500 Subject: [PATCH 340/478] Also test on macOS --- .github/workflows/ci.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index bc63b06..8897a64 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -11,6 +11,7 @@ jobs: strategy: matrix: os: + - macos-10.15 - ubuntu-18.04 ghc: - 8.8.4 -- 2.30.2 From 01de8ea9b1bb75daaf843c50444a6c1fe9868a26 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 08:43:37 -0500 Subject: [PATCH 341/478] Only upload artifacts from Ubuntu --- .github/workflows/ci.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 8897a64..6d189a8 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -36,7 +36,8 @@ jobs: ${{ matrix.os }}-${{ matrix.ghc }}- - run: cabal test --test-show-details direct - run: cabal sdist - - uses: actions/upload-artifact@v2 + - if: matrix.os == 'ubuntu-18.04' + uses: actions/upload-artifact@v2 with: path: dist-newstyle/sdist/brittany-*.tar.gz name: brittany-${{ github.sha }}.tar.gz -- 2.30.2 From 0a48b0f1064e64c6ce8db7298ef237f07bbf1600 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 08:52:02 -0500 Subject: [PATCH 342/478] Also test on Windows --- .github/workflows/ci.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 6d189a8..ba48686 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -13,6 +13,7 @@ jobs: os: - macos-10.15 - ubuntu-18.04 + - windows-2019 ghc: - 8.8.4 cabal: -- 2.30.2 From 05dd912283513436f63c5c2739da066742db5502 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 08:58:21 -0500 Subject: [PATCH 343/478] Also test with GHC 8.6.5 --- .github/workflows/ci.yaml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index ba48686..dfa79c0 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -18,6 +18,10 @@ jobs: - 8.8.4 cabal: - 3.2.0.0 + include: + - os: ubuntu-18.04 + ghc: 8.6.5 + cabal: 3.2.0.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 @@ -37,7 +41,7 @@ jobs: ${{ matrix.os }}-${{ matrix.ghc }}- - run: cabal test --test-show-details direct - run: cabal sdist - - if: matrix.os == 'ubuntu-18.04' + - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.8.4' uses: actions/upload-artifact@v2 with: path: dist-newstyle/sdist/brittany-*.tar.gz -- 2.30.2 From 52603fa8cb7b0c6c0440d2aaa10c62bf3428c5ed Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:01:51 -0500 Subject: [PATCH 344/478] Upload binaries --- .github/workflows/ci.yaml | 5 +++++ output/.gitignore | 2 ++ 2 files changed, 7 insertions(+) create mode 100644 output/.gitignore diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index dfa79c0..483778e 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -40,6 +40,11 @@ jobs: ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}- ${{ matrix.os }}-${{ matrix.ghc }}- - run: cabal test --test-show-details direct + - run: cabal install --installdir output --install-method copy + - uses: actions/upload-artifact@v2 + with: + path: output/brittany* + name: brittany-${{ matrix.os }}-ghc-${{ matrix.ghc }}-${{ github.sha }} - run: cabal sdist - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.8.4' uses: actions/upload-artifact@v2 diff --git a/output/.gitignore b/output/.gitignore new file mode 100644 index 0000000..d6b7ef3 --- /dev/null +++ b/output/.gitignore @@ -0,0 +1,2 @@ +* +!.gitignore -- 2.30.2 From 213de6a16c3208b2f34688ff42efdb25f39723b5 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:21:35 -0500 Subject: [PATCH 345/478] Strip executables --- .github/workflows/ci.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 483778e..5a96f43 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -41,6 +41,7 @@ jobs: ${{ matrix.os }}-${{ matrix.ghc }}- - run: cabal test --test-show-details direct - run: cabal install --installdir output --install-method copy + - run: strip output/brittany* - uses: actions/upload-artifact@v2 with: path: output/brittany* -- 2.30.2 From 2d8d1f4d8685d048d9db508d665fa30a95b92d15 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:22:02 -0500 Subject: [PATCH 346/478] Also test with GHC 8.10.2 --- .github/workflows/ci.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 5a96f43..a590b4a 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -19,6 +19,9 @@ jobs: cabal: - 3.2.0.0 include: + - os: ubuntu-18.04 + ghc: 8.10.2 + cabal: 3.2.0.0 - os: ubuntu-18.04 ghc: 8.6.5 cabal: 3.2.0.0 -- 2.30.2 From 5f8d70e5f00ede2b8563722138740a4e4eb561f3 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:24:19 -0500 Subject: [PATCH 347/478] Revert "Also test with GHC 8.10.2" This reverts commit 2d8d1f4d8685d048d9db508d665fa30a95b92d15. --- .github/workflows/ci.yaml | 3 --- 1 file changed, 3 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index a590b4a..5a96f43 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -19,9 +19,6 @@ jobs: cabal: - 3.2.0.0 include: - - os: ubuntu-18.04 - ghc: 8.10.2 - cabal: 3.2.0.0 - os: ubuntu-18.04 ghc: 8.6.5 cabal: 3.2.0.0 -- 2.30.2 From fb8e3825aa3223ed434c9b40120bb3cdfa62f833 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:29:28 -0500 Subject: [PATCH 348/478] Also test with GHC 8.4.4 --- .github/workflows/ci.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 5a96f43..8466f5a 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -22,6 +22,9 @@ jobs: - os: ubuntu-18.04 ghc: 8.6.5 cabal: 3.2.0.0 + - os: ubuntu-18.04 + ghc: 8.4.4 + cabal: 3.2.0.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 -- 2.30.2 From f333302406882a6b102a537d1e7dfc722f4cdc9e Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:29:43 -0500 Subject: [PATCH 349/478] Also test with GHC 8.2.2 --- .github/workflows/ci.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 8466f5a..b916b03 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -25,6 +25,9 @@ jobs: - os: ubuntu-18.04 ghc: 8.4.4 cabal: 3.2.0.0 + - os: ubuntu-18.04 + ghc: 8.2.2 + cabal: 3.2.0.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 -- 2.30.2 From 751ec8848aa37645d2cb3a9e6f5f5650f2be9080 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:30:12 -0500 Subject: [PATCH 350/478] Also test with GHC 8.0.2 --- .github/workflows/ci.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index b916b03..e3c50a5 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -28,6 +28,9 @@ jobs: - os: ubuntu-18.04 ghc: 8.2.2 cabal: 3.2.0.0 + - os: ubuntu-18.04 + ghc: 8.0.2 + cabal: 3.2.0.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 -- 2.30.2 From 47865b708cafbaaddd8f1036de5441ba9b303022 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 09:50:41 -0500 Subject: [PATCH 351/478] Remove unnecessary call to sdist For some reason `cabal install` does sdist. --- .github/workflows/ci.yaml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e3c50a5..2ebc7b5 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -55,7 +55,6 @@ jobs: with: path: output/brittany* name: brittany-${{ matrix.os }}-ghc-${{ matrix.ghc }}-${{ github.sha }} - - run: cabal sdist - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.8.4' uses: actions/upload-artifact@v2 with: -- 2.30.2 From b960a3f4ac07027df2c9f5f01e291774585c07f9 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 12:44:05 -0500 Subject: [PATCH 352/478] Version 0.12.2.0 --- ChangeLog.md | 21 ++++++++++++++++++--- brittany.cabal | 2 +- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 2de61e6..41c1825 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Revision history for brittany +## 0.12.2.0 -- November 2020 + +* #207: Fix newtype indent in associated type family. +* #231: Improve comments-affecting-layout behaviour for tuples. +* #259: Data declaration for newtype and records. Thanks @eborden! +* #263: Fix non-idempotent newlines with comment + where. +* #273: Error handling. +* #281: Fix moving comment in export list (haddock header). +* #286: Fix comments in instance/type instances. +* #287: Add support for pattern synonyms. Thanks @RaoulHC! +* #293: Expose main function as a module. Thanks @soareschen! +* #303: Readme: Supports 8.8. Thanks @andys8! +* #311: Allows aeson-1.5.*. Thanks @jkachmar! +* #313: Nondecreasing export list formatting. Thanks @expipiplus1! + ## 0.12.1.1 -- December 2019 * Bugfixes: @@ -90,11 +105,11 @@ multiline-comments are supported too, although the specification must still be a single line. E.g. - + > "{- brittany --columns 50 -}" - + CONFIG is either: - + 1) one or more flags in the form of what brittany accepts on the commandline, e.g. "--columns 50", or 2) one or more specifications in the form of what brittany diff --git a/brittany.cabal b/brittany.cabal index dc0e796..818e818 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.12.1.1 +version: 0.12.2.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 10aec170052c25845918986a2df61b5a7acfcad5 Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 13 May 2020 10:44:11 +0200 Subject: [PATCH 353/478] Use allow-newer to build not updated pkgs --- cabal.project | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 cabal.project diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..051d727 --- /dev/null +++ b/cabal.project @@ -0,0 +1,7 @@ +packages: . + +allow-newer: multistate:base, + data-tree-print:base, + czipwith:base, + czipwith:template-haskell, + butcher:base -- 2.30.2 From 17d07edb0a687053fbeb39e0bdf07415ee35a278 Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 13 May 2020 10:44:37 +0200 Subject: [PATCH 354/478] Relax upper bounds to include updated packages --- brittany.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 818e818..590373f 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -91,10 +91,10 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.9 && <4.14 - , ghc >=8.0.1 && <8.9 + { base >=4.9 && <4.15 + , ghc >=8.0.1 && <8.11 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.6.3 + , ghc-exactprint >=0.5.8 && <0.6.4 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 @@ -118,7 +118,7 @@ library { , semigroups >=0.18.2 && <0.20 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.0.1 && <8.9 + , ghc-boot-th >=8.0.1 && <8.11 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 } -- 2.30.2 From b69a8f983c070564b41b6fdec160af6d8aff730b Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 13 May 2020 10:45:14 +0200 Subject: [PATCH 355/478] Adapt to new GHC modules organization --- .../Haskell/Brittany/Internal/ExactPrintUtils.hs | 6 ++++++ src/Language/Haskell/Brittany/Internal/Prelude.hs | 8 ++++++-- src/Language/Haskell/Brittany/Internal/Utils.hs | 15 ++++++++++++--- 3 files changed, 24 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 0273d85..5dcf840 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -33,7 +33,13 @@ import qualified Lexer as GHC import qualified StringBuffer as GHC import qualified Outputable as GHC import qualified CmdLineParser as GHC + +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif + import SrcLoc ( SrcSpan, Located ) diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 453f076..a0757d8 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -13,9 +13,13 @@ where -- rather project-specific stuff: --------------------------------- -#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs.Extension as E ( GhcPs ) +#else +# if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ import HsExtension as E ( GhcPs ) -#endif +# endif /* ghc-8.4 */ +#endif /* ghc-8.10.1 */ import RdrName as E ( RdrName ) #if MIN_VERSION_ghc(8,8,0) diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 435ad96..9edcb7e 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -59,9 +59,13 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate -#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import qualified GHC.Hs.Extension as HsExtension +#else +# if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ import qualified HsExtension -#endif +# endif /* ghc-8.4 */ +#endif /* ghc-8.10.1 */ @@ -299,6 +303,10 @@ lines' s = case break (== '\n') s of (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +absurdExt :: HsExtension.NoExtField -> a +absurdExt = error "cannot construct NoExtField" +#else #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ -- | A method to dismiss NoExt patterns for total matches absurdExt :: HsExtension.NoExt -> a @@ -306,4 +314,5 @@ absurdExt = error "cannot construct NoExt" #else absurdExt :: () absurdExt = () -#endif +#endif /* ghc-8.6 */ +#endif /* ghc-8.10.1 */ -- 2.30.2 From 9913b45086efba5164adf4532b7b7816f1839c16 Mon Sep 17 00:00:00 2001 From: Javier Neira Date: Thu, 6 Aug 2020 12:24:48 +0200 Subject: [PATCH 356/478] Update cabal.project Only data-tree-print is needed now Co-authored-by: Luke Lau --- cabal.project | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/cabal.project b/cabal.project index 051d727..3e5665f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,7 +1,3 @@ packages: . -allow-newer: multistate:base, - data-tree-print:base, - czipwith:base, - czipwith:template-haskell, - butcher:base +allow-newer: data-tree-print:base -- 2.30.2 From adb642353d6c3166eea4f52dc3ba83382dcaef04 Mon Sep 17 00:00:00 2001 From: Ximin Luo Date: Fri, 29 May 2020 23:26:51 +0100 Subject: [PATCH 357/478] more GHC 8.10.1 fixes --- src/Language/Haskell/Brittany/Internal.hs | 9 +++++++ .../Brittany/Internal/ExactPrintUtils.hs | 11 +++++++- .../Brittany/Internal/Layouters/DataDecl.hs | 4 +++ .../Brittany/Internal/Layouters/Decl.hs | 15 ++++++++--- .../Brittany/Internal/Layouters/Expr.hs | 25 ++++++++++++++++++- .../Brittany/Internal/Layouters/Expr.hs-boot | 4 +++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 7 +++++- .../Brittany/Internal/Layouters/Import.hs | 12 +++++++++ .../Brittany/Internal/Layouters/Module.hs | 7 +++++- .../Brittany/Internal/Layouters/Pattern.hs | 12 +++++++++ .../Brittany/Internal/Layouters/Stmt.hs | 4 +++ .../Brittany/Internal/Layouters/Stmt.hs-boot | 4 +++ .../Brittany/Internal/Layouters/Type.hs | 12 +++++++-- .../Haskell/Brittany/Internal/Utils.hs | 10 +++----- 14 files changed, 121 insertions(+), 15 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 1d9266f..1fc3e12 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -61,7 +61,12 @@ import GHC ( Located ) import RdrName ( RdrName(..) ) import SrcLoc ( SrcSpan ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +import Bag +#else import HsSyn +#endif import qualified DynFlags as GHC import qualified GHC.LanguageExtensions.Type as GHC @@ -380,7 +385,11 @@ parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) +#else Left (_ , s ) -> return $ Left $ "parsing error: " ++ s +#endif Right (anns, parsedModule) -> runExceptT $ do (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 5dcf840..6115f52 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -36,6 +36,7 @@ import qualified CmdLineParser as GHC #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs +import Bag #else import HsSyn #endif @@ -96,7 +97,11 @@ parseModuleWithCpp cpp opts args fp dynCheck = ++ show (warnings <&> warnExtractorCompat) x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) +#else either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) +#endif (\(a, m) -> pure (a, m, x)) $ ExactPrint.postParseTransform res opts @@ -129,7 +134,11 @@ parseModuleFromString args fp dynCheck str = dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) +#else Left (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err +#endif Right (a , m ) -> pure (a, m, dynCheckRes) @@ -193,7 +202,7 @@ commentAnnFixTransformGlob ast = do , ExactPrint.annsDP = assocs' } ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns - + commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 00453b3..4d2b93a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -19,7 +19,11 @@ import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import qualified GHC +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name import BasicTypes import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index f33b511..8ec8d74 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -37,8 +37,10 @@ import GHC ( runGhc ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import qualified FastString -import HsSyn -#if MIN_VERSION_ghc(8,6,0) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +import GHC.Hs.Extension (NoExtField (..)) +#elif MIN_VERSION_ghc(8,6,0) import HsExtension (NoExt (..)) #endif import Name @@ -1040,7 +1042,14 @@ layoutClsInst lcid@(L _ cid) = docLines ] where layoutInstanceHead :: ToBriDocM BriDocNumbered -#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + layoutInstanceHead = + briDocByExactNoComment + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren + <$> lcid +#elif MIN_VERSION_ghc(8,6,0) /* 8.6 */ layoutInstanceHead = briDocByExactNoComment $ InstD NoExt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 660355c..d7c9a2b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -19,7 +19,11 @@ import Language.Haskell.Brittany.Internal.Config.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name import qualified FastString import BasicTypes @@ -521,7 +525,12 @@ layoutExpr lexpr@(L _ expr) = do #else ExplicitTuple args boxity -> do #endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + let argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e); + (L _ (Missing NoExtField)) -> (arg, Nothing) + (L _ XTupArg{}) -> error "brittany internal error: XTupArg" +#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let argExprs = args <&> \arg -> case arg of (L _ (Present _ e)) -> (arg, Just e); (L _ (Missing NoExt)) -> (arg, Nothing) @@ -984,10 +993,18 @@ layoutExpr lexpr@(L _ expr) = do else Just <$> docSharedWrapper layoutExpr rFExpr return $ (lfield, lrdrNameToText lnameF, rFExpDoc) recordExpression False indentPolicy lexpr nameDoc rFs +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + HsRecFields [] (Just (L _ 0)) -> do +#else HsRecFields [] (Just 0) -> do +#endif let t = lrdrNameToText lname docWrapNode lname $ docLit $ t <> Text.pack " { .. }" +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do +#else HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do +#endif let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -1137,12 +1154,15 @@ layoutExpr lexpr@(L _ expr) = do HsStatic{} -> do -- TODO briDocByExactInlineOnly "HsStatic{}" lexpr +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +#else HsArrApp{} -> do -- TODO briDocByExactInlineOnly "HsArrApp{}" lexpr HsArrForm{} -> do -- TODO briDocByExactInlineOnly "HsArrForm{}" lexpr +#endif HsTick{} -> do -- TODO briDocByExactInlineOnly "HsTick{}" lexpr @@ -1152,6 +1172,8 @@ layoutExpr lexpr@(L _ expr) = do HsTickPragma{} -> do -- TODO briDocByExactInlineOnly "HsTickPragma{}" lexpr +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +#else EWildPat{} -> do docLit $ Text.pack "_" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -1169,6 +1191,7 @@ layoutExpr lexpr@(L _ expr) = do ELazyPat{} -> do -- TODO briDocByExactInlineOnly "ELazyPat{}" lexpr +#endif HsWrap{} -> do -- TODO briDocByExactInlineOnly "HsWrap{}" lexpr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 1f76032..733ac90 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -15,7 +15,11 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import GHC ( runGhc, GenLocated(L), moduleNameString ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index f2c36de..bfe2679 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -18,9 +18,14 @@ import GHC ( unLoc , AnnKeywordId(..) , Located ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +import GHC.Hs.ImpExp +#else import HsSyn -import Name import HsImpExp +#endif +import Name import FieldLabel import qualified FastString import BasicTypes diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index bcce106..d5bf0dd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -12,7 +12,11 @@ import GHC ( unLoc , moduleNameString , Located ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name import FieldLabel import qualified FastString @@ -59,7 +63,11 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + let qualifiedPart = if q /= NotQualified then length "qualified " else 0 +#else let qualifiedPart = if q then length "qualified " else 0 +#endif safePart = if safe then length "safe " else 0 pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT srcPart = if src then length "{-# SOURCE #-} " else 0 @@ -73,7 +81,11 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of [ appSep $ docLit $ Text.pack "import" , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty +#else , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty +#endif , maybe docEmpty (appSep . docLit) pkgNameT ] indentName = diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index f899e08..3839ecd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -9,9 +9,14 @@ import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Config.Types import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +import GHC.Hs.ImpExp +#else import HsSyn -import Name import HsImpExp +#endif +import Name import FieldLabel import qualified FastString import BasicTypes diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index cd1b31e..de943b7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -21,7 +21,11 @@ import GHC ( Located , ol_val ) import qualified GHC +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name import BasicTypes @@ -136,14 +140,22 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of , docSeparator , docLit $ Text.pack "}" ] +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + ConPatIn lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do +#else ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do +#endif -- Abc { .. } -> expr let t = lrdrNameToText lname Seq.singleton <$> docSeq [ appSep $ docLit t , docLit $ Text.pack "{..}" ] +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ + ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do +#else ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do +#endif -- Abc { a = locA, .. } let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 3aa3b5c..60ba54b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -17,7 +17,11 @@ import GHC ( runGhc , GenLocated(L) , moduleNameString ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name import qualified FastString import BasicTypes diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index faf583a..1fab3c5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -13,7 +13,11 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import GHC ( runGhc, GenLocated(L), moduleNameString ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name import qualified FastString import BasicTypes diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 940eac7..7a1fee4 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -25,7 +25,11 @@ import GHC ( runGhc , AnnKeywordId (..) ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) +#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Hs +#else import HsSyn +#endif import Name import Outputable ( ftext, showSDocUnsafe ) import BasicTypes @@ -61,7 +65,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of t <- lrdrNameToTextAnnTypeEqualityIsSpecial name docWrapNode name $ docLit t #endif -#if MIN_VERSION_ghc(8,6,0) +#if MIN_VERSION_ghc(8,10,1) + HsForAllTy _ _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do +#elif MIN_VERSION_ghc(8,6,0) HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do #else HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do @@ -151,7 +157,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] -#if MIN_VERSION_ghc(8,6,0) +#if MIN_VERSION_ghc(8,10,1) + HsForAllTy _ _ bndrs typ2 -> do +#elif MIN_VERSION_ghc(8,6,0) HsForAllTy _ bndrs typ2 -> do #else HsForAllTy bndrs typ2 -> do diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 9edcb7e..0a0d31f 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -304,15 +304,13 @@ lines' s = case break (== '\n') s of (s1, (_:r)) -> s1 : lines' r #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -absurdExt :: HsExtension.NoExtField -> a -absurdExt = error "cannot construct NoExtField" -#else -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +absurdExt :: HsExtension.NoExtCon -> a +absurdExt = HsExtension.noExtCon +#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ -- | A method to dismiss NoExt patterns for total matches absurdExt :: HsExtension.NoExt -> a absurdExt = error "cannot construct NoExt" #else absurdExt :: () absurdExt = () -#endif /* ghc-8.6 */ -#endif /* ghc-8.10.1 */ +#endif -- 2.30.2 From 1e118a44ca9880b5e96f85a6f8c12d756f08fa8b Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 6 Aug 2020 18:50:10 +0100 Subject: [PATCH 358/478] Fix build on GHC 8.8 and below --- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 8ec8d74..e512b9a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -41,6 +41,7 @@ import qualified FastString import GHC.Hs import GHC.Hs.Extension (NoExtField (..)) #elif MIN_VERSION_ghc(8,6,0) +import HsSyn import HsExtension (NoExt (..)) #endif import Name -- 2.30.2 From cf3bc5daf46220b609a7ffac6cd26a717c62edb7 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Wed, 28 Oct 2020 08:45:29 -0400 Subject: [PATCH 359/478] Allow strict 0.4 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 590373f..704d505 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -110,7 +110,7 @@ library { , aeson >=1.0.1.0 && <1.6 , extra >=1.4.10 && <1.8 , uniplate >=1.6.12 && <1.7 - , strict >=0.3.2 && <0.4 + , strict >=0.3.2 && <0.5 , monad-memo >=0.4.1 && <0.6 , unsafe >=0.0 && <0.1 , safe >=0.3.9 && <0.4 -- 2.30.2 From 045c387ff4ec8ce60c976d9eaafb36088b135ede Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 10:11:24 -0500 Subject: [PATCH 360/478] Remove unnecessary configuration The latest revision of data-tree-print allows base 4.14. --- cabal.project | 3 --- 1 file changed, 3 deletions(-) delete mode 100644 cabal.project diff --git a/cabal.project b/cabal.project deleted file mode 100644 index 3e5665f..0000000 --- a/cabal.project +++ /dev/null @@ -1,3 +0,0 @@ -packages: . - -allow-newer: data-tree-print:base -- 2.30.2 From 23dace16ed4404baaed6bf1e0b3af458dc25af2a Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 10:28:36 -0500 Subject: [PATCH 361/478] Don't fail fast --- .github/workflows/ci.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 2ebc7b5..e79c8d1 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -9,6 +9,7 @@ on: jobs: build: strategy: + fail-fast: false matrix: os: - macos-10.15 -- 2.30.2 From 096c438b2351288cbf237da652bad1ceca1d8cdb Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 11:10:06 -0500 Subject: [PATCH 362/478] Drop support for GHC 8.0 --- .github/workflows/ci.yaml | 3 -- .travis.yml | 12 ++--- Makefile | 7 +-- README.md | 10 ++-- brittany.cabal | 6 +-- .../Haskell/Brittany/Internal/Config/Types.hs | 4 -- .../Brittany/Internal/ExactPrintUtils.hs | 2 +- .../Brittany/Internal/Layouters/DataDecl.hs | 26 +-------- .../Brittany/Internal/Layouters/Decl.hs | 46 ++++------------ .../Brittany/Internal/Layouters/Expr.hs | 54 ++++--------------- .../Brittany/Internal/Layouters/Expr.hs-boot | 2 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 16 ------ .../Brittany/Internal/Layouters/Import.hs | 10 ---- .../Brittany/Internal/Layouters/Pattern.hs | 15 ++---- .../Brittany/Internal/Layouters/Type.hs | 21 +------- .../Haskell/Brittany/Internal/Prelude.hs | 6 +-- .../Haskell/Brittany/Internal/Types.hs | 2 - stack-8.0.2.yaml | 12 ----- stack-8.0.2.yaml.lock | 54 ------------------- 19 files changed, 43 insertions(+), 265 deletions(-) delete mode 100644 stack-8.0.2.yaml delete mode 100644 stack-8.0.2.yaml.lock diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e79c8d1..7ad0476 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -29,9 +29,6 @@ jobs: - os: ubuntu-18.04 ghc: 8.2.2 cabal: 3.2.0.0 - - os: ubuntu-18.04 - ghc: 8.0.2 - cabal: 3.2.0.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 diff --git a/.travis.yml b/.travis.yml index ae64c83..cd70c46 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,7 +40,7 @@ before_cache: # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} matrix: include: - + ##### OSX test via stack ##### # Build on macOS in addition to Linux @@ -49,10 +49,7 @@ matrix: os: osx ##### CABAL ##### - - - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.0.2" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.2.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} @@ -92,9 +89,6 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml" - compiler: ": #stack 8.0.2" - addons: {apt: {packages: [libgmp-dev]}} - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml" compiler: ": #stack 8.2.2" addons: {apt: {packages: [libgmp-dev]}} @@ -202,7 +196,7 @@ install: mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M700M -RTS"; fi - + # snapshot package-db on cache miss if [ ! -d $HOME/.cabsnap ]; then diff --git a/Makefile b/Makefile index e0213ab..c7524be 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ test: .PHONY: test-all test-all: - $(MAKE) test test-8.6.5 test-8.4.3 test-8.2.2 test-8.0.2 + $(MAKE) test test-8.6.5 test-8.4.3 test-8.2.2 .PHONY: test-8.6.5 test-8.6.5: @@ -21,8 +21,3 @@ test-8.4.3: test-8.2.2: echo "test 8.2.2" stack test --stack-yaml stack-8.2.2.yaml --work-dir .stack-work-8.2.2 - -.PHONY: test-8.0.2 -test-8.0.2: - echo "test 8.0.2" - stack test --stack-yaml stack-8.0.2.yaml --work-dir .stack-work-8.0.2 diff --git a/README.md b/README.md index 6fe5976..b009a37 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# 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) +# 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) @@ -31,7 +31,7 @@ require fixing: other module elements (data-decls, classes, instances, etc.) are not transformed in any way; this extends to e.g. **bindings inside class instance definitions** - they **won't be touched** (yet). -- By using `ghc-exactprint` as the parser, brittany supports full GHC +- By using `ghc-exactprint` as the parser, brittany supports full GHC including extensions, but **some of the less common syntactic elements (even of 2010 haskell) are not handled**. - **There are some known issues regarding handling of in-source comments.** @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`, `8.8`. +- Supports GHC versions `8.2`, `8.4`, `8.6`, `8.8`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. @@ -127,13 +127,13 @@ log the size of the input, but _not_ the full input/output of requests.) - Default mode of operation: Transform a single module, from `stdin` to `stdout`. Can pass one or multiple files as input, and there is a flag to override them in place instead of using `stdout` (since 0.9.0.0). So: - + ~~~~ .sh brittany # stdin -> stdout brittany mysource.hs # ./mysource.hs -> stdout brittany --write-mode=inplace *.hs # apply formatting to all ./*.hs inplace ~~~~ - + - For stdin/stdout usage it makes sense to enable certain syntactic extensions by default, i.e. to add something like this to your `~/.config/brittany/config.yaml` (execute `brittany` once to create default): diff --git a/brittany.cabal b/brittany.cabal index 704d505..0c3ed7c 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -91,8 +91,8 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.9 && <4.15 - , ghc >=8.0.1 && <8.11 + { base >=4.10 && <4.15 + , ghc >=8.2.1 && <8.11 , ghc-paths >=0.1.0.9 && <0.2 , ghc-exactprint >=0.5.8 && <0.6.4 , transformers >=0.5.2.0 && <0.6 @@ -118,7 +118,7 @@ library { , semigroups >=0.18.2 && <0.20 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.0.1 && <8.11 + , ghc-boot-th >=8.2.1 && <8.11 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 } diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 32da0ac..c5d8eb0 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -229,15 +229,12 @@ deriving instance Data (CForwardOptions Identity) deriving instance Data (CPreProcessorConfig Identity) deriving instance Data (CConfig Identity) -#if MIN_VERSION_ghc(8,2,0) --- these instances break on earlier ghcs deriving instance Data (CDebugConfig Option) deriving instance Data (CLayoutConfig Option) deriving instance Data (CErrorHandlingConfig Option) deriving instance Data (CForwardOptions Option) deriving instance Data (CPreProcessorConfig Option) deriving instance Data (CConfig Option) -#endif instance Semigroup.Semigroup (CDebugConfig Option) where (<>) = gmappend @@ -356,4 +353,3 @@ deriveCZipWith ''CErrorHandlingConfig deriveCZipWith ''CForwardOptions deriveCZipWith ''CPreProcessorConfig deriveCZipWith ''CConfig - diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 6115f52..7c06f69 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -323,7 +323,7 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat (GHC.Warn _ (L _ s)) = s -#else /* ghc-8.0 && ghc-8.2 */ +#else /* ghc-8.2 */ warnExtractorCompat :: GenLocated l String -> String warnExtractorCompat (L _ s) = s #endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 4d2b93a..74b6d53 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -297,7 +297,6 @@ createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered createDerivingPar derivs mainDoc = do case derivs of -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (L _ []) -> mainDoc (L _ types) -> docPar mainDoc @@ -306,26 +305,13 @@ createDerivingPar derivs mainDoc = do $ docWrapNode derivs $ derivingClauseDoc <$> types -#else - Nothing -> mainDoc - Just types -> - docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ derivingClauseDoc types -#endif -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -#else -derivingClauseDoc :: Located [LHsSigType GhcPs] -> ToBriDocM BriDocNumbered -#endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ -derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of #else -derivingClauseDoc types = case types of +derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of #endif (L _ []) -> docSeq [] (L _ ts) -> @@ -333,11 +319,7 @@ derivingClauseDoc types = case types of tsLength = length ts whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy -#else - (lhsStrategy, rhsStrategy) = (docEmpty, docEmpty) -#endif in docSeq [ docDeriving @@ -351,15 +333,12 @@ derivingClauseDoc types = case types of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIB _ t -> layoutType t XHsImplicitBndrs x -> absurdExt x -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ - HsIB _ t _ -> layoutType t #else - HsIB _ t -> layoutType t + HsIB _ t _ -> layoutType t #endif , whenMoreThan1Type ")" , rhsStrategy ] -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */ where strategyLeftRight = \case (L _ StockStrategy ) -> (docLitS " stock", docEmpty) @@ -377,7 +356,6 @@ derivingClauseDoc types = case types of XHsImplicitBndrs ext -> absurdExt ext ) #endif -#endif docDeriving :: ToBriDocM BriDocNumbered docDeriving = docLitS "deriving" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index e512b9a..4a86954 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -49,9 +49,7 @@ import BasicTypes ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) -#if MIN_VERSION_ghc(8,2,0) , LexicalFixity(..) -#endif ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) @@ -100,10 +98,8 @@ layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ +#else /* ghc-8.2 */ TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ -#else /* ghc-8.0 */ - TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> @@ -128,17 +124,13 @@ layoutSig lsig@(L _loc sig) = case sig of <> Text.pack " #-}" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ +#else /* ghc-8.2 */ ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ -#else /* ghc-8.0 */ - ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ -#elif MIN_VERSION_ghc(8,2,0) - PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ #else - PatSynSig name (HsIB _ typ) -> layoutNamesAndType (Just "pattern") [name] typ + PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ #endif _ -> briDocByExactNoComment lsig -- TODO where @@ -359,10 +351,8 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId #elif MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ Match (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.4 */ - Match (FunRhs matchId _ _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId #else - Match (FunBindMatch matchId _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId + Match (FunRhs matchId _ _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId #endif _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr @@ -406,7 +396,6 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do mWhereArg hasComments -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 && ghc-8.4 */ fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match @@ -424,10 +413,6 @@ fixPatternBindIdentifier match idStr = go $ m_ctxt match (ParStmtCtxt ctx1) -> goInner ctx1 (TransStmtCtxt ctx1) -> goInner ctx1 _ -> idStr -#else /* ghc-8.0 */ -fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text -fixPatternBindIdentifier _ x = x -#endif layoutPatternBindFinal :: Maybe Text @@ -842,18 +827,11 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of let isInfix = case fixity of Prefix -> False Infix -> True -#elif MIN_VERSION_ghc(8,2,0) +#else SynDecl name vars fixity typ _ -> do let isInfix = case fixity of Prefix -> False Infix -> True -#else - SynDecl name vars typ _ -> do - nameStr <- lrdrNameToTextAnn name - let isInfixTypeOp = case Text.uncons nameStr of - Nothing -> False - Just (c, _) -> not (c == '(' || isUpper c) - isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote #endif -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen @@ -864,10 +842,8 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ #if MIN_VERSION_ghc(8,6,0) DataDecl _ext name tyVars _ dataDefn -> -#elif MIN_VERSION_ghc(8,2,0) - DataDecl name tyVars _ dataDefn _ _ -> #else - DataDecl name tyVars dataDefn _ _ -> + DataDecl name tyVars _ dataDefn _ _ -> #endif layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl @@ -919,14 +895,14 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do #if MIN_VERSION_ghc(8,6,0) /* 8.6 */ XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" UserTyVar _ name -> do -#else /* 8.0 8.2 8.4 */ +#else /* 8.2 8.4 */ UserTyVar name -> do #endif nameStr <- lrdrNameToTextAnn name docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] #if MIN_VERSION_ghc(8,6,0) /* 8.6 */ KindedTyVar _ name kind -> do -#else /* 8.0 8.2 8.4 */ +#else /* 8.2 8.4 */ KindedTyVar name kind -> do #endif nameStr <- lrdrNameToTextAnn name @@ -967,12 +943,8 @@ layoutTyFamInstDecl inClass outerNode tfid = do FamEqn name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing innerNode = outerNode -#elif MIN_VERSION_ghc(8,2,0) - innerNode@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid - bndrsMay = Nothing - pats = hsib_body boundPats #else - innerNode@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid + innerNode@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index d7c9a2b..534496d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -62,10 +62,8 @@ layoutExpr lexpr@(L _ expr) = do briDocByExactInlineOnly "HsRecFld" lexpr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsOverLabel _ext _reboundFromLabel name -> -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ +#else /* ghc-8.2 */ HsOverLabel _reboundFromLabel name -> -#else /* ghc-8.0 */ - HsOverLabel name -> #endif let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label @@ -176,19 +174,15 @@ layoutExpr lexpr@(L _ expr) = do #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ (L _ []) _) -> do -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ +#else /* ghc-8.2 */ HsLamCase (MG (L _ []) _ _ _) -> do -#else /* ghc-8.0 */ - HsLamCase _ (MG (L _ []) _ _ _) -> do #endif docSetParSpacing $ docAddBaseY BrIndentRegular $ (docLit $ Text.pack "\\case {}") #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/ +#else /* 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 @@ -311,10 +305,8 @@ layoutExpr lexpr@(L _ expr) = do HsAppType XHsWildCardBndrs{} _ -> error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType (HsWC _ ty1) exp1 -> do -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ +#else /* 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 @@ -329,7 +321,7 @@ layoutExpr lexpr@(L _ expr) = do e (docSeq [docLit $ Text.pack "@", t ]) ] -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ HsAppTypeOut{} -> do -- TODO briDocByExactInlineOnly "HsAppTypeOut{}" lexpr @@ -968,7 +960,7 @@ layoutExpr lexpr@(L _ expr) = do in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ExplicitList _ _ [] -> docLit $ Text.pack "[]" -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ ExplicitPArr{} -> do -- TODO briDocByExactInlineOnly "ExplicitPArr{}" lexpr @@ -1052,10 +1044,8 @@ layoutExpr lexpr@(L _ expr) = do ExprWithTySig XHsWildCardBndrs{} _ -> error "brittany internal error: ExprWithTySig XHsWildCardBndrs" ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8,4 */ +#else /* 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 @@ -1064,7 +1054,7 @@ layoutExpr lexpr@(L _ expr) = do , appSep $ docLit $ Text.pack "::" , typDoc ] -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ ExprWithTySigOut{} -> do -- TODO briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr @@ -1113,7 +1103,7 @@ layoutExpr lexpr@(L _ expr) = do ] ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.0 8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ PArrSeq{} -> do -- TODO briDocByExactInlineOnly "PArrSeq{}" lexpr @@ -1195,14 +1185,12 @@ layoutExpr lexpr@(L _ expr) = do 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,6,0) /* ghc-8.6 */ XExpr{} -> error "brittany internal error: XExpr" #endif @@ -1367,7 +1355,7 @@ overLitValBriDoc = \case HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +#else /* ghc-8.2 */ litBriDoc :: HsLit -> BriDocFInt litBriDoc = \case HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] @@ -1391,26 +1379,4 @@ overLitValBriDoc = \case HsFractional (FL t _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" -#else /* ghc-8.0 */ -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 - HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger 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 - -overLitValBriDoc :: OverLitVal -> BriDocFInt -overLitValBriDoc = \case - 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/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 733ac90..606790b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -30,7 +30,7 @@ layoutExpr :: ToBriDoc HsExpr #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ litBriDoc :: HsLit GhcPs -> BriDocFInt -#else /* ghc-8.0 && ghc-8.2 */ +#else /* ghc-8.2 */ litBriDoc :: HsLit -> BriDocFInt #endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bfe2679..739d138 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -34,13 +34,8 @@ import Language.Haskell.Brittany.Internal.Utils -#if MIN_VERSION_ghc(8,2,0) prepareName :: LIEWrappedName name -> Located name prepareName = ieLWrappedName -#else -prepareName :: Located name -> Located name -prepareName = id -#endif layoutIE :: ToBriDoc IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of @@ -111,7 +106,6 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of ] _ -> docEmpty where -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2, 8.4, .. */ layoutWrapped _ = \case L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEPattern n) -> do @@ -120,16 +114,6 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of L _ (IEType n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "type " <> name -#else /* ghc-8.0 */ - layoutWrapped outer n = do - name <- lrdrNameToTextAnn n - hasType <- hasAnnKeyword n AnnType - hasPattern <- hasAnnKeyword outer AnnPattern - docLit $ if - | hasType -> Text.pack "type (" <> name <> Text.pack ")" - | hasPattern -> Text.pack "pattern " <> name - | otherwise -> name -#endif -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index d5bf0dd..ac29eda 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -26,24 +26,14 @@ import Language.Haskell.Brittany.Internal.Utils -#if MIN_VERSION_ghc(8,2,0) prepPkg :: SourceText -> String prepPkg rawN = case rawN of SourceText n -> n -- This would be odd to encounter and the -- result will most certainly be wrong NoSourceText -> "" -#else -prepPkg :: String -> String -prepPkg = id -#endif -#if MIN_VERSION_ghc(8,2,0) prepModName :: Located e -> e prepModName = unLoc -#else -prepModName :: e -> e -prepModName = id -#endif layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index de943b7..b0b13f2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -50,14 +50,14 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of -- _ -> expr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ VarPat _ n -> -#else /* ghc-8.0 8.2 8.4 */ +#else /* ghc-8.2 8.4 */ VarPat n -> #endif fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ LitPat _ lit -> -#else /* ghc-8.0 8.2 8.4 */ +#else /* ghc-8.2 8.4 */ LitPat lit -> #endif fmap Seq.singleton $ allocateNode $ litBriDoc lit @@ -66,7 +66,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of ParPat _ inner -> do #elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ParPat _ inner -> do -#else /* ghc-8.0 8.2 8.4 */ +#else /* ghc-8.2 8.4 */ ParPat inner -> do #endif -- (nestedpat) -> expr @@ -202,10 +202,8 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do #elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ +#else /* ghc-8.2 */ SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do -#else /* ghc-8.0 */ - SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do #endif -- i :: Int -> expr patDocs <- layoutPat pat1 @@ -260,11 +258,6 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc --- if MIN_VERSION_ghc(8,0,0) --- VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n --- else --- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n --- endif _ -> return <$> briDocByExactInlineOnly "some unknown pattern" (ghcDL lpat) colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 7a1fee4..2060904 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -42,7 +42,6 @@ import DataTreePrint 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) #if MIN_VERSION_ghc(8,6,0) HsTyVar _ promoted name -> do #else /* ghc-8.2 ghc-8.4 */ @@ -60,11 +59,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docWrapNode name $ docLit t ] NotPromoted -> docWrapNode name $ docLit t -#else /* ghc-8.0 */ - HsTyVar name -> do - t <- lrdrNameToTextAnnTypeEqualityIsSpecial name - docWrapNode name $ docLit t -#endif #if MIN_VERSION_ghc(8,10,1) HsForAllTy _ _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do #elif MIN_VERSION_ghc(8,6,0) @@ -547,10 +541,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- } #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do -#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ +#else /* ghc-8.2 */ HsIParamTy (L _ (HsIPName ipName)) typ1 -> do -#else /* ghc-8.0 */ - HsIParamTy (HsIPName ipName) typ1 -> do #endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -699,11 +691,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of briDocByExactInlineOnly "HsDocTy{}" ltype HsRecTy{} -> -- TODO 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 hasComments <- hasAnyCommentsBelow ltype let specialCommaSep = appSep $ docLit $ Text.pack " ," @@ -755,27 +743,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of #else HsTyLit lit -> case lit of #endif -#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 #if !MIN_VERSION_ghc(8,6,0) HsCoreTy{} -> -- TODO briDocByExactInlineOnly "HsCoreTy{}" ltype #endif HsWildCardTy _ -> docLit $ Text.pack "_" -#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype -#endif #if MIN_VERSION_ghc(8,6,0) HsStarTy _ isUnicode -> do if isUnicode diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index a0757d8..79e2975 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,4 +1,4 @@ -#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.2 */ {-# LANGUAGE TypeFamilies #-} #endif @@ -411,7 +411,7 @@ todo :: a todo = error "todo" -#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.2 */ type family IdP p type instance IdP GhcPs = RdrName @@ -422,7 +422,7 @@ type GhcPs = RdrName #if MIN_VERSION_ghc(8,8,0) ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) ghcDL = GHC.dL -#else /* ghc-8.0 8.2 8.4 8.6 */ +#else /* ghc-8.2 8.4 8.6 */ ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x #endif diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 620a39b..f402e56 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -32,9 +32,7 @@ data PerItemConfig = PerItemConfig { _icd_perBinding :: Map String (CConfig Option) , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option) } -#if MIN_VERSION_ghc(8,2,0) deriving Data.Data.Data -#endif type PPM = MultiRWSS.MultiRWS '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml deleted file mode 100644 index 80928db..0000000 --- a/stack-8.0.2.yaml +++ /dev/null @@ -1,12 +0,0 @@ -resolver: lts-9.0 - -extra-deps: - - monad-memo-0.4.1 - - czipwith-1.0.1.0 - - butcher-1.3.1.1 - - data-tree-print-0.1.0.0 - - deque-0.2 - - ghc-exactprint-0.5.8.0 - -packages: - - . \ No newline at end of file diff --git a/stack-8.0.2.yaml.lock b/stack-8.0.2.yaml.lock deleted file mode 100644 index 08d3ffb..0000000 --- a/stack-8.0.2.yaml.lock +++ /dev/null @@ -1,54 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - hackage: monad-memo-0.4.1@sha256:d7575b0c89ad21818ca5746170d10a3b92f01fdf9028fa37d3a370e42b24b38b,3672 - pantry-tree: - size: 1823 - sha256: 8d7bcc8a8bce43804613a160fd7f0fea7869a54e530a9f1b9f9e853ec4e00b57 - original: - hackage: monad-memo-0.4.1 -- completed: - hackage: czipwith-1.0.1.0@sha256:30751c5a92488304863f20403cd8e9d4fee2b5def0b656a3d979aa3331a09c00,1652 - pantry-tree: - size: 323 - sha256: acd60968c5a1945741204751243f88d1af1c152018c2d9575f62c0805825f44f - original: - hackage: czipwith-1.0.1.0 -- completed: - hackage: butcher-1.3.1.1@sha256:d5734df2e42c28c5a8419eb8251cc531e5f5e6a13794b2ae1dac04abd1c359ad,3242 - pantry-tree: - size: 1197 - sha256: 057b5c8aa0211951337d87cda1f3d4c6f049945314f6fc7883394eebac79be5b - original: - hackage: butcher-1.3.1.1 -- completed: - hackage: data-tree-print-0.1.0.0@sha256:6610723626501d3ab65dc2290c0de59de8d042caf72a1db1e0cd01e84d229346,1547 - pantry-tree: - size: 272 - sha256: caa741fd498f754b42d45a16aae455056d5e71df51e960fce1579b8e8b6496ad - original: - hackage: data-tree-print-0.1.0.0 -- completed: - hackage: deque-0.2@sha256:a9736298cd04472924b3b681b3791c99e8b6009a6e5df1ff13dd57457109ad43,877 - pantry-tree: - size: 205 - sha256: c48e1f58dfac107ba9dd8d159d4c033fd72521de678204788e3f01f7a2e17546 - original: - hackage: deque-0.2 -- completed: - hackage: ghc-exactprint-0.5.8.0@sha256:71915a08a7d442d39a63cb3b0fbd90b7dacd19bc4b05bac5c53b6e8a0d931b7b,7728 - pantry-tree: - size: 83871 - sha256: 3998143d33f7de29b31e8cf8d1b207c1fb4962f819fc820e209e1eecbf7e5a35 - original: - hackage: ghc-exactprint-0.5.8.0 -snapshots: -- completed: - size: 533451 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/9/0.yaml - sha256: 27f29b231b39ea68e967a7a4346b2693a49d77c50f41fc0c276e11189a538da7 - original: lts-9.0 -- 2.30.2 From 259c949211448eee97d5cb8e9db97e42e113235f Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 11:32:34 -0500 Subject: [PATCH 363/478] Drop support for GHC 8.2 --- .github/workflows/ci.yaml | 3 -- .travis.yml | 20 --------- Makefile | 7 +-- README.md | 2 +- brittany.cabal | 6 +-- .../Brittany/Internal/ExactPrintUtils.hs | 5 --- .../Brittany/Internal/Layouters/Decl.hs | 38 +++------------- .../Brittany/Internal/Layouters/Expr.hs | 44 ++++--------------- .../Brittany/Internal/Layouters/Expr.hs-boot | 4 -- .../Brittany/Internal/Layouters/Pattern.hs | 8 ++-- .../Brittany/Internal/Layouters/Type.hs | 6 +-- .../Haskell/Brittany/Internal/Prelude.hs | 17 +------ .../Haskell/Brittany/Internal/Utils.hs | 2 - stack-8.2.2.yaml | 9 ---- stack-8.2.2.yaml.lock | 33 -------------- 15 files changed, 28 insertions(+), 176 deletions(-) delete mode 100644 stack-8.2.2.yaml delete mode 100644 stack-8.2.2.yaml.lock diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 7ad0476..6fb70ec 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -26,9 +26,6 @@ jobs: - os: ubuntu-18.04 ghc: 8.4.4 cabal: 3.2.0.0 - - os: ubuntu-18.04 - ghc: 8.2.2 - cabal: 3.2.0.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 diff --git a/.travis.yml b/.travis.yml index cd70c46..d9b2b07 100644 --- a/.travis.yml +++ b/.travis.yml @@ -43,16 +43,8 @@ matrix: ##### OSX test via stack ##### - # Build on macOS in addition to Linux - - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml" - compiler: ": #stack 8.2.2 osx" - os: osx - ##### CABAL ##### - - env: BUILD=cabal GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.2.2" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - env: BUILD=cabal GHCVER=8.4.4 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.4.4" addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} @@ -66,17 +58,8 @@ matrix: # compiler: ": #GHC HEAD" # addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - ##### CABAL DIST CHECK - - - env: BUILD=cabaldist GHCVER=8.2.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.2.2 dist" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - ##### CANEW ##### - - env: BUILD=canew GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal new 8.2.2" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - env: BUILD=canew GHCVER=8.8.1 CABALVER=3.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal new 8.8.1" addons: {apt: {packages: [cabal-install-3.0,ghc-8.8.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} @@ -89,9 +72,6 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--stack-yaml stack-8.2.2.yaml" - compiler: ": #stack 8.2.2" - addons: {apt: {packages: [libgmp-dev]}} - env: BUILD=stack ARGS="--stack-yaml stack-8.4.3.yaml" compiler: ": #stack 8.4.3" addons: {apt: {packages: [libgmp-dev]}} diff --git a/Makefile b/Makefile index c7524be..1017b9a 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ test: .PHONY: test-all test-all: - $(MAKE) test test-8.6.5 test-8.4.3 test-8.2.2 + $(MAKE) test test-8.6.5 test-8.4.3 .PHONY: test-8.6.5 test-8.6.5: @@ -16,8 +16,3 @@ test-8.6.5: test-8.4.3: echo "test 8.4.3" stack test --stack-yaml stack-8.4.3.yaml --work-dir .stack-work-8.4.3 - -.PHONY: test-8.2.2 -test-8.2.2: - echo "test 8.2.2" - stack test --stack-yaml stack-8.2.2.yaml --work-dir .stack-work-8.2.2 diff --git a/README.md b/README.md index b009a37..56f42f0 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.2`, `8.4`, `8.6`, `8.8`. +- Supports GHC versions `8.4`, `8.6`, `8.8`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. diff --git a/brittany.cabal b/brittany.cabal index 0c3ed7c..ffeb0f2 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -91,8 +91,8 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.10 && <4.15 - , ghc >=8.2.1 && <8.11 + { base >=4.11 && <4.15 + , ghc >=8.4.1 && <8.11 , ghc-paths >=0.1.0.9 && <0.2 , ghc-exactprint >=0.5.8 && <0.6.4 , transformers >=0.5.2.0 && <0.6 @@ -118,7 +118,7 @@ library { , semigroups >=0.18.2 && <0.20 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.2.1 && <8.11 + , ghc-boot-th >=8.4.1 && <8.11 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 } diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 7c06f69..b7ac608 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -320,10 +320,5 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case in annsBalanced -#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat (GHC.Warn _ (L _ s)) = s -#else /* ghc-8.2 */ -warnExtractorCompat :: GenLocated l String -> String -warnExtractorCompat (L _ s) = s -#endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 4a86954..ae0b232 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -98,7 +98,7 @@ layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -124,7 +124,7 @@ layoutSig lsig@(L _loc sig) = case sig of <> Text.pack " #-}" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) @@ -165,19 +165,11 @@ layoutSig lsig@(L _loc sig) = case sig of specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String -#if MIN_VERSION_ghc(8,4,0) specStringCompat ast = \case NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" Inline -> pure "INLINE " Inlinable -> pure "INLINABLE " NoInline -> pure "NOINLINE " -#else -specStringCompat _ = \case - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " - EmptyInlineSpec -> pure "" -#endif layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of @@ -349,10 +341,8 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do mIdStr <- case match of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId -#elif MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ - Match (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId #else - Match (FunRhs matchId _ _) _ _ _ -> Just <$> lrdrNameToTextAnn matchId + Match (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId #endif _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr @@ -774,28 +764,16 @@ layoutLPatSyn :: Located (IdP GhcPs) -> HsPatSynDetails (Located (IdP GhcPs)) -> ToBriDocM BriDocNumbered -#if MIN_VERSION_ghc(8,4,0) layoutLPatSyn name (PrefixCon vars) = do -#else -layoutLPatSyn name (PrefixPatSyn vars) = do -#endif docName <- lrdrNameToTextAnn name names <- mapM lrdrNameToTextAnn vars docSeq . fmap appSep $ docLit docName : (docLit <$> names) -#if MIN_VERSION_ghc(8,4,0) layoutLPatSyn name (InfixCon left right) = do -#else -layoutLPatSyn name (InfixPatSyn left right) = do -#endif leftDoc <- lrdrNameToTextAnn left docName <- lrdrNameToTextAnn name rightDoc <- lrdrNameToTextAnn right docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] -#if MIN_VERSION_ghc(8,4,0) layoutLPatSyn name (RecCon recArgs) = do -#else -layoutLPatSyn name (RecordPatSyn recArgs) = do -#endif docName <- lrdrNameToTextAnn name args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs docSeq . fmap docLit @@ -895,14 +873,14 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do #if MIN_VERSION_ghc(8,6,0) /* 8.6 */ XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" UserTyVar _ name -> do -#else /* 8.2 8.4 */ +#else /* 8.4 */ UserTyVar name -> do #endif nameStr <- lrdrNameToTextAnn name docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] #if MIN_VERSION_ghc(8,6,0) /* 8.6 */ KindedTyVar _ name kind -> do -#else /* 8.2 8.4 */ +#else /* 8.4 */ KindedTyVar name kind -> do #endif nameStr <- lrdrNameToTextAnn name @@ -939,14 +917,10 @@ layoutTyFamInstDecl inClass outerNode tfid = do FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing innerNode = outerNode -#elif MIN_VERSION_ghc(8,4,0) +#else FamEqn name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing innerNode = outerNode -#else - innerNode@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid - bndrsMay = Nothing - pats = hsib_body boundPats #endif docWrapNodePrior outerNode $ do nameStr <- lrdrNameToTextAnn name diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 534496d..8c089c2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -62,7 +62,7 @@ layoutExpr lexpr@(L _ expr) = do briDocByExactInlineOnly "HsRecFld" lexpr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsOverLabel _ext _reboundFromLabel name -> -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ HsOverLabel _reboundFromLabel name -> #endif let label = FastString.unpackFS name @@ -174,14 +174,14 @@ layoutExpr lexpr@(L _ expr) = do #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ (L _ []) _) -> do -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ HsLamCase (MG (L _ []) _ _ _) -> do #endif docSetParSpacing $ docAddBaseY BrIndentRegular $ (docLit $ Text.pack "\\case {}") #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do #endif binderDoc <- docLit $ Text.pack "->" @@ -305,7 +305,7 @@ layoutExpr lexpr@(L _ expr) = do HsAppType XHsWildCardBndrs{} _ -> error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType (HsWC _ ty1) exp1 -> do -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ HsAppType exp1 (HsWC _ ty1) -> do #endif t <- docSharedWrapper layoutType ty1 @@ -321,7 +321,7 @@ layoutExpr lexpr@(L _ expr) = do e (docSeq [docLit $ Text.pack "@", t ]) ] -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ HsAppTypeOut{} -> do -- TODO briDocByExactInlineOnly "HsAppTypeOut{}" lexpr @@ -960,7 +960,7 @@ layoutExpr lexpr@(L _ expr) = do in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ExplicitList _ _ [] -> docLit $ Text.pack "[]" -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ ExplicitPArr{} -> do -- TODO briDocByExactInlineOnly "ExplicitPArr{}" lexpr @@ -1044,7 +1044,7 @@ layoutExpr lexpr@(L _ expr) = do ExprWithTySig XHsWildCardBndrs{} _ -> error "brittany internal error: ExprWithTySig XHsWildCardBndrs" ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #endif expDoc <- docSharedWrapper layoutExpr exp1 @@ -1054,7 +1054,7 @@ layoutExpr lexpr@(L _ expr) = do , appSep $ docLit $ Text.pack "::" , typDoc ] -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ ExprWithTySigOut{} -> do -- TODO briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr @@ -1103,7 +1103,7 @@ layoutExpr lexpr@(L _ expr) = do ] ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.2 8.4 */ +#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ PArrSeq{} -> do -- TODO briDocByExactInlineOnly "PArrSeq{}" lexpr @@ -1331,7 +1331,6 @@ recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do in [line1] ++ lineR ++ [dotdotLine, lineN] ) -#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc = \case HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] @@ -1355,28 +1354,3 @@ overLitValBriDoc = \case HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" -#else /* 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" -#endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 606790b..e3be109 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -28,10 +28,6 @@ layoutExpr :: ToBriDoc HsExpr -- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) -#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ litBriDoc :: HsLit GhcPs -> BriDocFInt -#else /* ghc-8.2 */ -litBriDoc :: HsLit -> BriDocFInt -#endif overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index b0b13f2..fb0ba51 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -50,14 +50,14 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of -- _ -> expr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ VarPat _ n -> -#else /* ghc-8.2 8.4 */ +#else /* ghc-8.4 */ VarPat n -> #endif fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ LitPat _ lit -> -#else /* ghc-8.2 8.4 */ +#else /* ghc-8.4 */ LitPat lit -> #endif fmap Seq.singleton $ allocateNode $ litBriDoc lit @@ -66,7 +66,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of ParPat _ inner -> do #elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ParPat _ inner -> do -#else /* ghc-8.2 8.4 */ +#else /* ghc-8.4 */ ParPat inner -> do #endif -- (nestedpat) -> expr @@ -202,7 +202,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do #elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do #endif -- i :: Int -> expr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 2060904..a2b55d7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -44,14 +44,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" #if MIN_VERSION_ghc(8,6,0) HsTyVar _ promoted name -> do -#else /* ghc-8.2 ghc-8.4 */ +#else /* ghc-8.4 */ HsTyVar promoted name -> do #endif t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of #if MIN_VERSION_ghc(8,8,0) IsPromoted -> docSeq -#else /* ghc-8.2 8.4 8.6 */ +#else /* ghc-8.4 8.6 */ Promoted -> docSeq #endif [ docSeparator @@ -541,7 +541,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- } #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do -#else /* ghc-8.2 */ +#else /* ghc-8.4 */ HsIParamTy (L _ (HsIPName ipName)) typ1 -> do #endif typeDoc1 <- docSharedWrapper layoutType typ1 diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 79e2975..e9a6979 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,8 +1,3 @@ -#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.2 */ -{-# LANGUAGE TypeFamilies #-} -#endif - - module Language.Haskell.Brittany.Internal.Prelude ( module E , module Language.Haskell.Brittany.Internal.Prelude @@ -16,9 +11,7 @@ where #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs.Extension as E ( GhcPs ) #else -# if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ import HsExtension as E ( GhcPs ) -# endif /* ghc-8.4 */ #endif /* ghc-8.10.1 */ import RdrName as E ( RdrName ) @@ -411,18 +404,10 @@ todo :: a todo = error "todo" -#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.2 */ -type family IdP p -type instance IdP GhcPs = RdrName - -type GhcPs = RdrName -#endif - - #if MIN_VERSION_ghc(8,8,0) ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) ghcDL = GHC.dL -#else /* ghc-8.2 8.4 8.6 */ +#else /* ghc-8.4 8.6 */ ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x #endif diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 0a0d31f..4b4061e 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -62,9 +62,7 @@ import qualified Data.Generics.Uniplate.Direct as Uniplate #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import qualified GHC.Hs.Extension as HsExtension #else -# if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ import qualified HsExtension -# endif /* ghc-8.4 */ #endif /* ghc-8.10.1 */ diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml deleted file mode 100644 index 1ce5fc3..0000000 --- a/stack-8.2.2.yaml +++ /dev/null @@ -1,9 +0,0 @@ -resolver: lts-11.1 - -extra-deps: - - czipwith-1.0.1.0 - - butcher-1.3.1.1 - - ghc-exactprint-0.5.8.0 - -packages: - - . diff --git a/stack-8.2.2.yaml.lock b/stack-8.2.2.yaml.lock deleted file mode 100644 index 8bacbb2..0000000 --- a/stack-8.2.2.yaml.lock +++ /dev/null @@ -1,33 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - hackage: czipwith-1.0.1.0@sha256:30751c5a92488304863f20403cd8e9d4fee2b5def0b656a3d979aa3331a09c00,1652 - pantry-tree: - size: 323 - sha256: acd60968c5a1945741204751243f88d1af1c152018c2d9575f62c0805825f44f - original: - hackage: czipwith-1.0.1.0 -- completed: - hackage: butcher-1.3.1.1@sha256:d5734df2e42c28c5a8419eb8251cc531e5f5e6a13794b2ae1dac04abd1c359ad,3242 - pantry-tree: - size: 1197 - sha256: 057b5c8aa0211951337d87cda1f3d4c6f049945314f6fc7883394eebac79be5b - original: - hackage: butcher-1.3.1.1 -- completed: - hackage: ghc-exactprint-0.5.8.0@sha256:71915a08a7d442d39a63cb3b0fbd90b7dacd19bc4b05bac5c53b6e8a0d931b7b,7728 - pantry-tree: - size: 83871 - sha256: 3998143d33f7de29b31e8cf8d1b207c1fb4962f819fc820e209e1eecbf7e5a35 - original: - hackage: ghc-exactprint-0.5.8.0 -snapshots: -- completed: - size: 505335 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/1.yaml - sha256: 59c853f993e736f430ad20d03eb5441c715d84359c035de906f970841887a8f8 - original: lts-11.1 -- 2.30.2 From e36d9bc465a4b1241812d5137d11b0cec3954548 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 11:56:19 -0500 Subject: [PATCH 364/478] Drop support for GHC 8.4 --- .github/workflows/ci.yaml | 3 - .travis.yml | 6 - Makefile | 7 +- README.md | 2 +- brittany.cabal | 6 +- src/Language/Haskell/Brittany/Internal.hs | 18 -- .../Brittany/Internal/ExactPrintUtils.hs | 8 - .../Brittany/Internal/Layouters/DataDecl.hs | 46 ---- .../Brittany/Internal/Layouters/Decl.hs | 123 +---------- .../Brittany/Internal/Layouters/Expr.hs | 197 +----------------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 24 --- .../Brittany/Internal/Layouters/Import.hs | 4 - .../Brittany/Internal/Layouters/Pattern.hs | 48 +---- .../Brittany/Internal/Layouters/Stmt.hs | 20 -- .../Brittany/Internal/Layouters/Type.hs | 153 +------------- .../Haskell/Brittany/Internal/Prelude.hs | 2 +- .../Haskell/Brittany/Internal/Utils.hs | 5 +- stack-8.4.3.yaml | 4 - stack-8.4.3.yaml.lock | 19 -- 19 files changed, 19 insertions(+), 676 deletions(-) delete mode 100644 stack-8.4.3.yaml delete mode 100644 stack-8.4.3.yaml.lock diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 6fb70ec..ae70751 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -23,9 +23,6 @@ jobs: - os: ubuntu-18.04 ghc: 8.6.5 cabal: 3.2.0.0 - - os: ubuntu-18.04 - ghc: 8.4.4 - cabal: 3.2.0.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 diff --git a/.travis.yml b/.travis.yml index d9b2b07..19a5ca9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -45,9 +45,6 @@ matrix: ##### CABAL ##### - - env: BUILD=cabal GHCVER=8.4.4 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.4.4" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.4.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - env: BUILD=cabal GHCVER=8.6.5 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #cabal 8.6.5" addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.5,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} @@ -72,9 +69,6 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--stack-yaml stack-8.4.3.yaml" - compiler: ": #stack 8.4.3" - addons: {apt: {packages: [libgmp-dev]}} - env: BUILD=stack ARGS="--stack-yaml stack-8.6.5.yaml" compiler: ": #stack 8.6.5" addons: {apt: {packages: [libgmp-dev]}} diff --git a/Makefile b/Makefile index 1017b9a..ca0a962 100644 --- a/Makefile +++ b/Makefile @@ -5,14 +5,9 @@ test: .PHONY: test-all test-all: - $(MAKE) test test-8.6.5 test-8.4.3 + $(MAKE) test test-8.6.5 .PHONY: test-8.6.5 test-8.6.5: echo "test 8.6.5" stack test --stack-yaml stack-8.6.5.yaml --work-dir .stack-work-8.6.5 - -.PHONY: test-8.4.3 -test-8.4.3: - echo "test 8.4.3" - stack test --stack-yaml stack-8.4.3.yaml --work-dir .stack-work-8.4.3 diff --git a/README.md b/README.md index 56f42f0..eec9c4c 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.4`, `8.6`, `8.8`. +- Supports GHC versions `8.6`, `8.8`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. diff --git a/brittany.cabal b/brittany.cabal index ffeb0f2..cd541fb 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -91,8 +91,8 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.11 && <4.15 - , ghc >=8.4.1 && <8.11 + { base >=4.12 && <4.15 + , ghc >=8.6.1 && <8.11 , ghc-paths >=0.1.0.9 && <0.2 , ghc-exactprint >=0.5.8 && <0.6.4 , transformers >=0.5.2.0 && <0.6 @@ -118,7 +118,7 @@ library { , semigroups >=0.18.2 && <0.20 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.4.1 && <8.11 + , ghc-boot-th >=8.6.1 && <8.11 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.2 } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 1fc3e12..57e6e8f 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -518,17 +518,10 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ getDeclBindingNames (L _ decl) = case decl of SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD _ (FunBind _ (L _ n) _ _ _) -> [Text.unpack $ rdrNameToText n] _ -> [] -#else -getDeclBindingNames (L _ decl) = case decl of - SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) - ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] -#endif -- Prints the information associated with the module annotation @@ -586,26 +579,15 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do _sigHead :: Sig GhcPs -> String _sigHead = \case -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ TypeSig _ names _ -> -#else - TypeSig names _ -> -#endif "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) _ -> "unknown sig" _bindHead :: HsBind GhcPs -> String -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ _bindHead = \case FunBind _ fId _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" _ -> "unknown bind" -#else -_bindHead = \case - FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) - PatBind _pat _ _ _ ([], []) -> "PatBind smth" - _ -> "unknown bind" -#endif diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index b7ac608..29c126f 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -212,17 +212,9 @@ commentAnnFixTransform modul = SYB.everything (>>) genF modul genF = (\_ -> return ()) `SYB.extQ` exprF exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () exprF lexpr@(L _ expr) = case expr of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> -#else - RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> -#endif moveTrailingComments lexpr (List.last fs) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecordUpd _ _e fs@(_:_) -> -#else - RecordUpd _e fs@(_:_) _cons _ _ _ -> -#endif moveTrailingComments lexpr (List.last fs) _ -> return () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 74b6d53..22f11d4 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -44,20 +44,11 @@ layoutDataDecl -> LHsQTyVars GhcPs -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -#else -layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of -#endif -- newtype MyType a b = MyType .. -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> -#else - HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _conDoc)) -> -#endif docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName @@ -82,11 +73,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of -- data MyData a b -- (zero constructors) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> -#else - HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> -#endif docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name @@ -100,17 +87,9 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of -- data MyData = MyData .. -- data MyData = MyData { .. } -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> -#else - HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> -#endif case cons of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> -#else - (L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) -> -#endif docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name @@ -266,18 +245,11 @@ createContextDoc (t1 : tR) = do createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do tyVarDocs <- bs `forM` \case -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) (L _ (KindedTyVar _ext lrdrName kind)) -> do -#else - (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do -#endif d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (XTyVarBndr ext)) -> absurdExt ext -#endif docSeq $ List.intersperse docSeparator $ tyVarDocs @@ -307,12 +279,8 @@ createDerivingPar derivs mainDoc = do <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of -#else -derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of -#endif (L _ []) -> docSeq [] (L _ ts) -> let @@ -330,12 +298,8 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of $ docSeq $ List.intersperse docCommaSep $ ts <&> \case -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIB _ t -> layoutType t XHsImplicitBndrs x -> absurdExt x -#else - HsIB _ t _ -> layoutType t -#endif , whenMoreThan1Type ")" , rhsStrategy ] @@ -344,7 +308,6 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of (L _ StockStrategy ) -> (docLitS " stock", docEmpty) (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ lVia@(L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of @@ -355,7 +318,6 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of ] XHsImplicitBndrs ext -> absurdExt ext ) -#endif docDeriving :: ToBriDocM BriDocNumbered docDeriving = docLitS "deriving" @@ -473,12 +435,8 @@ createDetailsDoc consNameStr details = case details of :: [LConDeclField GhcPs] -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] mkFieldDocs = fmap $ \lField -> case lField of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (XConDeclField x) -> absurdExt x -#else - L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t -#endif createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc [] = Nothing @@ -497,12 +455,8 @@ createNamesAndTypeDoc lField names t = $ List.intersperse docCommaSep $ names <&> \case -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ L _ (XFieldOcc x) -> absurdExt x L _ (FieldOcc _ fieldName) -> -#else - L _ (FieldOcc fieldName _) -> -#endif docLit =<< lrdrNameToTextAnn fieldName ] , docWrapNodeRest lField $ layoutType t diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index ae0b232..f6f59a4 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -40,7 +40,7 @@ import qualified FastString #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs import GHC.Hs.Extension (NoExtField (..)) -#elif MIN_VERSION_ghc(8,6,0) +#else import HsSyn import HsExtension (NoExt (..)) #endif @@ -65,7 +65,6 @@ import Data.Char (isUpper) layoutDecl :: ToBriDoc HsDecl -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutDecl d@(L loc decl) = case decl of SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case @@ -77,18 +76,6 @@ layoutDecl d@(L loc decl) = case decl of InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d -#else -layoutDecl d@(L loc decl) = case decl of - SigD sig -> withTransformedAnns d $ layoutSig (L loc sig) - ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD (TyFamInstD tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False d tfid - InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) - _ -> briDocByExactNoComment d -#endif -------------------------------------------------------------------------------- -- Sig @@ -96,16 +83,8 @@ layoutDecl d@(L loc decl) = case decl of layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ -#else /* ghc-8.4 */ - TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ -#endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> -#else - InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> -#endif docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig spec @@ -122,16 +101,8 @@ layoutSig lsig@(L _loc sig) = case sig of $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ -#else /* ghc-8.4 */ - ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ -#endif -#if MIN_VERSION_ghc(8,6,0) PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ -#else - PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ -#endif _ -> briDocByExactNoComment lsig -- TODO where layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do @@ -173,16 +144,8 @@ specStringCompat ast = \case layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ BodyStmt _ body _ _ -> layoutExpr body -#else - BodyStmt body _ _ _ -> layoutExpr body -#endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ BindStmt _ lPat expr _ _ -> do -#else - BindStmt lPat expr _ _ _ -> do -#endif patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docCols ColBindStmt @@ -201,11 +164,7 @@ layoutBind (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do -#else - FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do -#endif idStr <- lrdrNameToTextAnn fId binderDoc <- docLit $ Text.pack "=" funcPatDocs <- @@ -214,11 +173,7 @@ layoutBind lbind@(L _ bind) = case bind of $ layoutPatternBind (Just idStr) binderDoc `mapM` matches return $ Left $ funcPatDocs -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do -#else - PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do -#endif patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds @@ -233,10 +188,8 @@ layoutBind lbind@(L _ bind) = case bind of hasComments #if MIN_VERSION_ghc(8,8,0) PatSynBind _ (PSB _ patID lpat rpat dir) -> do -#elif MIN_VERSION_ghc(8,6,0) - PatSynBind _ (PSB _ patID lpat rpat dir) -> do #else - PatSynBind (PSB patID _ lpat rpat dir) -> do + PatSynBind _ (PSB _ patID lpat rpat dir) -> do #endif fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat @@ -245,14 +198,9 @@ layoutBind lbind@(L _ bind) = case bind of _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ XIPBind{} -> unknownNodeError "XIPBind" lipbind IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" IPBind _ (Left (L _ (HsIPName name))) expr -> do -#else - IPBind (Right _) _ -> error "brittany internal error: IPBind Right" - IPBind (Left (L _ (HsIPName name))) expr -> do -#endif ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name binderDoc <- docLit $ Text.pack "=" exprDoc <- layoutExpr expr @@ -274,11 +222,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsValBinds _ (ValBinds _ bindlrs sigs) -> do -#else - HsValBinds (ValBindsIn bindlrs sigs) -> do -#endif let unordered = [ BagBind b | b <- Data.Foldable.toList bindlrs ] ++ [ BagSig s | s <- sigs ] @@ -287,23 +231,12 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s return $ Just $ docs -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" XHsLocalBindsLR{} -> error "brittany internal error: XHsLocalBindsLR" -#else - x@(HsValBinds (ValBindsOut _binds _lsigs)) -> - -- i _think_ this case never occurs in non-processed ast - Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}" - (L noSrcSpan x) -#endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ x@(HsIPBinds _ XHsIPBinds{}) -> Just . (: []) <$> unknownNodeError "XHsIPBinds" (L noSrcSpan x) HsIPBinds _ (IPBinds _ bb) -> -#else - HsIPBinds (IPBinds bb _) -> -#endif Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing @@ -312,17 +245,11 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do -#else -layoutGrhs lgrhs@(L _ (GRHS guards body)) = do -#endif guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutGrhs (L _ (XGRHS{})) = error "brittany internal error: XGRHS" -#endif layoutPatternBind :: Maybe Text @@ -331,19 +258,11 @@ layoutPatternBind -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do let pats = m_pats match -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let (GRHSs _ grhss whereBinds) = m_grhss match -#else - let (GRHSs grhss whereBinds) = m_grhss match -#endif patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match mIdStr <- case match of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId -#else - Match (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId -#endif _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of @@ -785,11 +704,7 @@ layoutLPatSyn name (RecCon recArgs) = do -- pattern synonyms layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of -#if MIN_VERSION_ghc(8,6,0) ExplicitBidirectional (MG _ (L _ lbinds) _) -> do -#else - ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do -#endif binderDoc <- docLit $ Text.pack "=" Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing @@ -800,17 +715,10 @@ layoutPatSynWhere hs = case hs of layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of -#if MIN_VERSION_ghc(8,6,0) SynDecl _ name vars fixity typ -> do let isInfix = case fixity of Prefix -> False Infix -> True -#else - SynDecl name vars fixity typ _ -> do - let isInfix = case fixity of - Prefix -> False - Infix -> True -#endif -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl @@ -818,11 +726,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ -#if MIN_VERSION_ghc(8,6,0) DataDecl _ext name tyVars _ dataDefn -> -#else - DataDecl name tyVars _ dataDefn _ _ -> -#endif layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl @@ -870,19 +774,11 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of -#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" UserTyVar _ name -> do -#else /* 8.4 */ - UserTyVar name -> do -#endif nameStr <- lrdrNameToTextAnn name docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] -#if MIN_VERSION_ghc(8,6,0) /* 8.6 */ KindedTyVar _ name kind -> do -#else /* 8.4 */ - KindedTyVar name kind -> do -#endif nameStr <- lrdrNameToTextAnn name docSeq $ [ docSeparator | needsSep ] @@ -913,12 +809,8 @@ layoutTyFamInstDecl inClass outerNode tfid = do -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode -#elif MIN_VERSION_ghc(8,6,0) - FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid - bndrsMay = Nothing - innerNode = outerNode #else - FamEqn name pats _fixity typ = hsib_body $ tfid_eqn tfid + FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing innerNode = outerNode #endif @@ -996,20 +888,13 @@ layoutClsInst lcid@(L _ cid) = docLines . ClsInstD NoExtField . removeChildren <$> lcid -#elif MIN_VERSION_ghc(8,6,0) /* 8.6 */ +#else layoutInstanceHead = briDocByExactNoComment $ InstD NoExt . ClsInstD NoExt . removeChildren <$> lcid -#else - layoutInstanceHead = - briDocByExactNoComment - $ InstD - . ClsInstD - . removeChildren - <$> lcid #endif removeChildren :: ClsInstDecl p -> ClsInstDecl p diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 8c089c2..ae514f1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -44,65 +44,29 @@ layoutExpr lexpr@(L _ expr) = do .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsVar _ vname -> do -#else - HsVar vname -> do -#endif docLit =<< lrdrNameToTextAnn vname -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsUnboundVar _ var -> case var of -#else - HsUnboundVar var -> case var of -#endif OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname TrueExprHole oname -> docLit $ Text.pack $ occNameString oname HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsOverLabel _ext _reboundFromLabel name -> -#else /* ghc-8.4 */ - HsOverLabel _reboundFromLabel name -> -#endif let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIPVar _ext (HsIPName name) -> -#else - HsIPVar (HsIPName name) -> -#endif let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsOverLit _ olit -> do -#else - HsOverLit olit -> do -#endif allocateNode $ overLitValBriDoc $ ol_val olit -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLit _ lit -> do -#else - HsLit lit -> do -#endif allocateNode $ litBriDoc lit -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) -#else - HsLam (MG (L _ [lmatch@(L _ match)]) _ _ _) -#endif | pats <- m_pats match -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ , GRHSs _ [lgrhs] llocals <- m_grhss match -#else - , GRHSs [lgrhs] llocals <- m_grhss match -#endif , L _ EmptyLocalBinds {} <- llocals -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ , L _ (GRHS _ [] body) <- lgrhs -#else - , L _ (GRHS [] body) <- lgrhs -#endif -> do patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> fmap return $ do @@ -168,48 +132,26 @@ layoutExpr lexpr@(L _ expr) = do ] HsLam{} -> unknownNodeError "HsLam too complex" lexpr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ XMatchGroup{} -> error "brittany internal error: HsLamCase XMatchGroup" -#endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ (L _ []) _) -> do -#else /* ghc-8.4 */ - HsLamCase (MG (L _ []) _ _ _) -> do -#endif docSetParSpacing $ docAddBaseY BrIndentRegular $ (docLit $ Text.pack "\\case {}") -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do -#else /* ghc-8.4 */ - HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do -#endif binderDoc <- docLit $ Text.pack "->" funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsApp _ exp1@(L _ HsApp{}) exp2 -> do -#else - HsApp exp1@(L _ HsApp{}) exp2 -> do -#endif let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) gather list = \case -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ L _ (HsApp _ l r) -> gather (r:list) l -#else - L _ (HsApp l r) -> gather (r:list) l -#endif x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 let colsOrSequence = case headE of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ L _ (HsVar _ (L _ (Unqual occname))) -> -#else - L _ (HsVar (L _ (Unqual occname))) -> -#endif docCols (ColApp $ Text.pack $ occNameString occname) _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE @@ -255,11 +197,7 @@ layoutExpr lexpr@(L _ expr) = do ( docNonBottomSpacing $ docLines paramDocs ) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsApp _ exp1 exp2 -> do -#else - HsApp exp1 exp2 -> do -#endif -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 @@ -301,12 +239,10 @@ layoutExpr lexpr@(L _ expr) = do HsAppType _ _ XHsWildCardBndrs{} -> error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType _ exp1 (HsWC _ ty1) -> do -#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#else HsAppType XHsWildCardBndrs{} _ -> error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType (HsWC _ ty1) exp1 -> do -#else /* ghc-8.4 */ - HsAppType exp1 (HsWC _ ty1) -> do #endif t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 @@ -321,23 +257,10 @@ layoutExpr lexpr@(L _ expr) = do e (docSeq [docLit $ Text.pack "@", t ]) ] -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ - HsAppTypeOut{} -> do - -- TODO - briDocByExactInlineOnly "HsAppTypeOut{}" lexpr -#endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do -#else - OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do -#endif let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) gather opExprList = \case -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 -#else - (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 -#endif final -> (final, opExprList) (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand @@ -351,19 +274,11 @@ layoutExpr lexpr@(L _ expr) = do hasComLeft <- hasAnyCommentsConnected expLeft hasComOp <- hasAnyCommentsConnected expOp pure $ not hasComLeft && not hasComOp -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let allowPar = case (expOp, expRight) of (L _ (HsVar _ (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False _ -> True -#else - let allowPar = case (expOp, expRight) of - (L _ (HsVar (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ (L _ HsVar{}))) -> False - _ -> True -#endif runFilteredAlternative $ do -- > one + two + three -- or @@ -401,27 +316,15 @@ layoutExpr lexpr@(L _ expr) = do $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ OpApp _ expLeft expOp expRight -> do -#else - OpApp expLeft expOp _ expRight -> do -#endif expDocLeft <- docSharedWrapper layoutExpr expLeft expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let allowPar = case (expOp, expRight) of (L _ (HsVar _ (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False _ -> True -#else - let allowPar = case (expOp, expRight) of - (L _ (HsVar (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ (L _ HsVar{}))) -> False - _ -> True -#endif let leftIsDoBlock = case expLeft of L _ HsDo{} -> True _ -> False @@ -467,20 +370,12 @@ layoutExpr lexpr@(L _ expr) = do then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ NegApp _ op _ -> do -#else - NegApp op _ -> do -#endif opDoc <- docSharedWrapper layoutExpr op docSeq [ docLit $ Text.pack "-" , opDoc ] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsPar _ innerExp -> do -#else - HsPar innerExp -> do -#endif innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt [ docSeq @@ -496,41 +391,25 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack ")" ] ] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ SectionL _ left op -> do -- TODO: add to testsuite -#else - SectionL left op -> do -- TODO: add to testsuite -#endif leftDoc <- docSharedWrapper layoutExpr left opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ SectionR _ op right -> do -- TODO: add to testsuite -#else - SectionR op right -> do -- TODO: add to testsuite -#endif opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ExplicitTuple _ args boxity -> do -#else - ExplicitTuple args boxity -> do -#endif #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ let argExprs = args <&> \arg -> case arg of (L _ (Present _ e)) -> (arg, Just e); (L _ (Missing NoExtField)) -> (arg, Nothing) (L _ XTupArg{}) -> error "brittany internal error: XTupArg" -#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#else let argExprs = args <&> \arg -> case arg of (L _ (Present _ e)) -> (arg, Just e); (L _ (Missing NoExt)) -> (arg, Nothing) (L _ XTupArg{}) -> error "brittany internal error: XTupArg" -#else - let argExprs = args <&> \arg -> case arg of - (L _ (Present e)) -> (arg, Just e); - (L _ (Missing PlaceHolder)) -> (arg, Nothing) #endif argDocs <- forM argExprs $ docSharedWrapper @@ -576,15 +455,9 @@ layoutExpr lexpr@(L _ expr) = do lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] end = closeLit in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ _ XMatchGroup{} -> error "brittany internal error: HsCase XMatchGroup" -#endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ cExp (MG _ (L _ []) _) -> do -#else - HsCase cExp (MG (L _ []) _ _ _) -> do -#endif cExpDoc <- docSharedWrapper layoutExpr cExp docAlt [ docAddBaseY BrIndentRegular @@ -599,11 +472,7 @@ layoutExpr lexpr@(L _ expr) = do ) (docLit $ Text.pack "of {}") ] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do -#else - HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do -#endif cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" funcPatDocs <- docWrapNode lmatches @@ -627,11 +496,7 @@ layoutExpr lexpr@(L _ expr) = do (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) ] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIf _ _ ifExpr thenExpr elseExpr -> do -#else - HsIf _ ifExpr thenExpr elseExpr -> do -#endif ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr @@ -751,11 +616,7 @@ layoutExpr lexpr@(L _ expr) = do docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsLet _ binds exp1 -> do -#else - HsLet binds exp1 -> do -#endif expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. hasComments <- hasAnyCommentsBelow lexpr @@ -861,11 +722,7 @@ layoutExpr lexpr@(L _ expr) = do ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of -#else - HsDo stmtCtx (L _ stmts) _ -> case stmtCtx of -#endif DoExpr -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts docSetParSpacing @@ -960,26 +817,13 @@ layoutExpr lexpr@(L _ expr) = do in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ExplicitList _ _ [] -> docLit $ Text.pack "[]" -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ - ExplicitPArr{} -> do - -- TODO - briDocByExactInlineOnly "ExplicitPArr{}" lexpr -#endif -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecordCon _ lname fields -> -#else - RecordCon lname _ _ fields -> -#endif case fields of HsRecFields fs Nothing -> do let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname rFs <- fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let FieldOcc _ lnameF = fieldOcc -#else - let FieldOcc lnameF _ = fieldOcc -#endif rFExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr @@ -999,22 +843,14 @@ layoutExpr lexpr@(L _ expr) = do #endif let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let FieldOcc _ lnameF = fieldOcc -#else - let FieldOcc lnameF _ = fieldOcc -#endif fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) recordExpression True indentPolicy lexpr nameDoc fieldDocs _ -> unknownNodeError "RecordCon with puns" lexpr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecordUpd _ rExpr fields -> do -#else - RecordUpd rExpr fields _ _ _ _ -> do -#endif rExprDoc <- docSharedWrapper layoutExpr rExpr rFs <- fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do @@ -1022,15 +858,10 @@ layoutExpr lexpr@(L _ expr) = do then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ case ambName of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) XAmbiguousFieldOcc{} -> error "brittany internal error: XAmbiguousFieldOcc" -#else - Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) -#endif recordExpression False indentPolicy lexpr rExprDoc rFs #if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */ ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) -> @@ -1038,14 +869,12 @@ layoutExpr lexpr@(L _ expr) = do ExprWithTySig _ _ XHsWildCardBndrs{} -> error "brittany internal error: ExprWithTySig XHsWildCardBndrs" ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do -#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#else ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ -> error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" ExprWithTySig XHsWildCardBndrs{} _ -> error "brittany internal error: ExprWithTySig XHsWildCardBndrs" ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do -#else /* ghc-8.4 */ - ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do #endif expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 @@ -1054,11 +883,6 @@ layoutExpr lexpr@(L _ expr) = do , appSep $ docLit $ Text.pack "::" , typDoc ] -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ - ExprWithTySigOut{} -> do - -- TODO - briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr -#endif ArithSeq _ Nothing info -> case info of From e1 -> do @@ -1103,11 +927,6 @@ layoutExpr lexpr@(L _ expr) = do ] ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr -#if !MIN_VERSION_ghc(8,6,0) /* ghc-8.4 */ - PArrSeq{} -> do - -- TODO - briDocByExactInlineOnly "PArrSeq{}" lexpr -#endif HsSCC{} -> do -- TODO briDocByExactInlineOnly "HsSCC{}" lexpr @@ -1123,11 +942,7 @@ layoutExpr lexpr@(L _ expr) = do HsTcBracketOut{} -> do -- TODO briDocByExactInlineOnly "HsTcBracketOut{}" lexpr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do -#else - HsSpliceE (HsQuasiQuote _ quoter _loc content) -> do -#endif allocateNode $ BDFPlain (Text.pack $ "[" @@ -1166,11 +981,7 @@ layoutExpr lexpr@(L _ expr) = do #else EWildPat{} -> do docLit $ Text.pack "_" -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ EAsPat _ asName asExpr -> do -#else - EAsPat asName asExpr -> do -#endif docSeq [ docLit $ lrdrNameToText asName <> Text.pack "@" , layoutExpr asExpr @@ -1191,9 +1002,7 @@ layoutExpr lexpr@(L _ expr) = do ExplicitSum{} -> do -- TODO briDocByExactInlineOnly "ExplicitSum{}" lexpr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ XExpr{} -> error "brittany internal error: XExpr" -#endif recordExpression :: (Data.Data.Data lExpr, Data.Data.Data name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 739d138..4f7ec0e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -39,32 +39,12 @@ prepareName = ieLWrappedName layoutIE :: ToBriDoc IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -#if MIN_VERSION_ghc(8,6,0) IEVar _ x -> layoutWrapped lie x -#else - IEVar x -> layoutWrapped lie x -#endif -#if MIN_VERSION_ghc(8,6,0) IEThingAbs _ x -> layoutWrapped lie x -#else - IEThingAbs x -> layoutWrapped lie x -#endif -#if MIN_VERSION_ghc(8,6,0) IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] -#else - IEThingAll x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] -#endif -#if MIN_VERSION_ghc(8,6,0) IEThingWith _ x (IEWildcard _) _ _ -> -#else - IEThingWith x (IEWildcard _) _ _ -> -#endif docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] -#if MIN_VERSION_ghc(8,6,0) IEThingWith _ x _ ns _ -> do -#else - IEThingWith x _ ns _ -> do -#endif hasComments <- orM ( hasCommentsBetween lie AnnOpenP AnnCloseP : hasAnyCommentsBelow x @@ -95,11 +75,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] -#if MIN_VERSION_ghc(8,6,0) IEModuleContents _ n -> docSeq -#else - IEModuleContents n -> docSeq -#endif [ docLit $ Text.pack "module" , docSeparator , docLit . Text.pack . moduleNameString $ unLoc n diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index ac29eda..cdcd8ed 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -37,11 +37,7 @@ prepModName = unLoc layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of -#if MIN_VERSION_ghc(8,6,0) ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do -#else - ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do -#endif importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index fb0ba51..037d693 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -48,26 +48,16 @@ layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ VarPat _ n -> -#else /* ghc-8.4 */ - VarPat n -> -#endif fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ LitPat _ lit -> -#else /* ghc-8.4 */ - LitPat lit -> -#endif fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr #if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ ParPat _ inner -> do -#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#else ParPat _ inner -> do -#else /* ghc-8.4 */ - ParPat inner -> do #endif -- (nestedpat) -> expr left <- docLit $ Text.pack "(" @@ -117,11 +107,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let FieldOcc _ lnameF = fieldOcc -#else - let FieldOcc lnameF _ = fieldOcc -#endif fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat @@ -159,11 +145,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of -- Abc { a = locA, .. } let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ let FieldOcc _ lnameF = fieldOcc -#else - let FieldOcc lnameF _ = fieldOcc -#endif fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutPat fPat @@ -181,29 +163,19 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of (fieldName, Nothing) -> [docLit fieldName, docCommaSep] , docLit $ Text.pack "..}" ] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ TuplePat _ args boxity -> do -#else - TuplePat args boxity _ -> do -#endif -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of Boxed -> wrapPatListy args "()" docParenL docParenR Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ AsPat _ asName asPat -> do -#else - AsPat asName asPat -> do -#endif -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") #if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do -#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#else SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do -#else /* ghc-8.4 */ - SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do #endif -- i :: Int -> expr patDocs <- layoutPat pat1 @@ -224,33 +196,17 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of , docForceSingleline tyDoc ] return $ xR Seq.|> xN' -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ ListPat _ elems -> -#else - ListPat elems _ _ -> -#endif -- [] -> expr1 -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 wrapPatListy elems "[]" docBracketL docBracketR -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ BangPat _ pat1 -> do -#else - BangPat pat1 -> do -#endif -- !nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "!") -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ LazyPat _ pat1 -> do -#else - LazyPat pat1 -> do -#endif -- ~nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "~") -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ NPat _ llit@(L _ ol) mNegative _ -> do -#else - NPat llit@(L _ ol) mNegative _ _ -> do -#endif -- -13 -> expr litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 60ba54b..5427d7a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -38,17 +38,9 @@ layoutStmt lstmt@(L _ stmt) = do indentAmount :: Int <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack docWrapNode lstmt $ case stmt of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ LastStmt _ body False _ -> do -#else - LastStmt body False _ -> do -#endif layoutExpr body -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ BindStmt _ lPat expr _ _ -> do -#else - BindStmt lPat expr _ _ _ -> do -#endif patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docAlt @@ -67,11 +59,7 @@ layoutStmt lstmt@(L _ stmt) = do $ docPar (docLit $ Text.pack "<-") (expDoc) ] ] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ LetStmt _ binds -> do -#else - LetStmt binds -> do -#endif let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case @@ -116,11 +104,7 @@ layoutStmt lstmt@(L _ stmt) = do $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do -#else - RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do -#endif -- rec stmt1 -- stmt2 -- stmt3 @@ -136,11 +120,7 @@ layoutStmt lstmt@(L _ stmt) = do addAlternative $ docAddBaseY BrIndentRegular $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ BodyStmt _ expr _ _ -> do -#else - BodyStmt expr _ _ _ -> do -#endif expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index a2b55d7..3437fcd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -42,16 +42,12 @@ import DataTreePrint 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,6,0) HsTyVar _ promoted name -> do -#else /* ghc-8.4 */ - HsTyVar promoted name -> do -#endif t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of #if MIN_VERSION_ghc(8,8,0) IsPromoted -> docSeq -#else /* ghc-8.4 8.6 */ +#else /* ghc-8.6 */ Promoted -> docSeq #endif [ docSeparator @@ -61,10 +57,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of NotPromoted -> docWrapNode name $ docLit t #if MIN_VERSION_ghc(8,10,1) HsForAllTy _ _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do -#elif MIN_VERSION_ghc(8,6,0) - HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do #else - HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do + HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do #endif typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs @@ -153,10 +147,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] #if MIN_VERSION_ghc(8,10,1) HsForAllTy _ _ bndrs typ2 -> do -#elif MIN_VERSION_ghc(8,6,0) - HsForAllTy _ bndrs typ2 -> do #else - HsForAllTy bndrs typ2 -> do + HsForAllTy _ bndrs typ2 -> do #endif typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs @@ -212,11 +204,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] -#if MIN_VERSION_ghc(8,6,0) HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do -#else - HsQualTy lcntxts@(L _ cntxts) typ1 -> do -#endif typeDoc <- docSharedWrapper layoutType typ1 cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let @@ -266,11 +254,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] -#if MIN_VERSION_ghc(8,6,0) HsFunTy _ typ1 typ2 -> do -#else - HsFunTy typ1 typ2 -> do -#endif typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 let maybeForceML = case typ2 of @@ -294,11 +278,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] -#if MIN_VERSION_ghc(8,6,0) HsParTy _ typ1 -> do -#else - HsParTy typ1 -> do -#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -313,7 +293,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ]) (docLit $ Text.pack ")") ] -#if MIN_VERSION_ghc(8,6,0) HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) gather list = \case @@ -341,65 +320,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) ] -#else - HsAppTy typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - docAlt - [ docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docForceSingleline typeDoc2 - ] - , docPar - typeDoc1 - (docEnsureIndent BrIndentRegular typeDoc2) - ] - HsAppsTy [] -> error "HsAppsTy []" - HsAppsTy [L _ (HsAppPrefix typ1)] -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc1 - HsAppsTy [lname@(L _ (HsAppInfix name))] -> do - -- this redirection is somewhat hacky, but whatever. - -- TODO: a general problem when doing deep inspections on - -- the type (and this is not the only instance) - -- is that we potentially omit annotations on some of - -- the middle constructors. i have no idea under which - -- circumstances exactly important annotations (comments) - -- would be assigned to such constructors. - typeDoc1 <- -- docSharedWrapper layoutType $ (L l $ HsTyVar name) - lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lname name - docLit typeDoc1 - HsAppsTy (L _ (HsAppPrefix typHead):typRestA) - | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t - _ -> Nothing) typRestA -> do - docHead <- docSharedWrapper layoutType typHead - docRest <- docSharedWrapper layoutType `mapM` typRest - docAlt - [ docSeq - $ docForceSingleline docHead : (docRest >>= \d -> - [ docSeparator, docForceSingleline d ]) - , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) - ] - HsAppsTy (typHead:typRest) -> do - docHead <- docSharedWrapper layoutAppType typHead - docRest <- docSharedWrapper layoutAppType `mapM` typRest - docAlt - [ docSeq - $ docForceSingleline docHead : (docRest >>= \d -> - [ docSeparator, docForceSingleline d ]) - , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) - ] - where - layoutAppType (L _ (HsAppPrefix t)) = layoutType t - layoutAppType lt@(L _ (HsAppInfix t)) = - docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t -#endif -#if MIN_VERSION_ghc(8,6,0) HsListTy _ typ1 -> do -#else - HsListTy typ1 -> do -#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -414,29 +335,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ]) (docLit $ Text.pack "]") ] -#if MIN_VERSION_ghc(8,6,0) -#else - HsPArrTy typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "[:" - , docForceSingleline typeDoc1 - , docLit $ Text.pack ":]" - ] - , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[:" - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack ":]") - ] -#endif -#if MIN_VERSION_ghc(8,6,0) HsTupleTy _ tupleSort typs -> case tupleSort of -#else - HsTupleTy tupleSort typs -> case tupleSort of -#endif HsUnboxedTuple -> unboxed HsBoxedTuple -> simple HsConstraintTuple -> simple @@ -539,11 +438,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- } -- , _layouter_ast = ltype -- } -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do -#else /* ghc-8.4 */ - HsIParamTy (L _ (HsIPName ipName)) typ1 -> do -#endif typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq @@ -562,33 +457,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docAddBaseY (BrIndentSpecial 2) typeDoc1 ]) ] -#if MIN_VERSION_ghc(8,6,0) -#else - HsEqTy typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - docAlt - [ docSeq - [ docForceSingleline typeDoc1 - , docWrapNodeRest ltype - $ docLit $ Text.pack " ~ " - , docForceSingleline typeDoc2 - ] - , docPar - typeDoc1 - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype - $ docLit $ Text.pack "~ " - , docAddBaseY (BrIndentSpecial 2) typeDoc2 - ]) - ] -#endif -- TODO: test KindSig -#if MIN_VERSION_ghc(8,6,0) HsKindSig _ typ1 kind1 -> do -#else - HsKindSig typ1 kind1 -> do -#endif typeDoc1 <- docSharedWrapper layoutType typ1 kindDoc1 <- docSharedWrapper layoutType kind1 hasParens <- hasAnnKeyword ltype AnnOpenP @@ -738,32 +608,22 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype -#if MIN_VERSION_ghc(8,6,0) HsTyLit _ lit -> case lit of -#else - HsTyLit lit -> case lit of -#endif 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" -#if !MIN_VERSION_ghc(8,6,0) - HsCoreTy{} -> -- TODO - briDocByExactInlineOnly "HsCoreTy{}" ltype -#endif HsWildCardTy _ -> docLit $ Text.pack "_" HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype -#if MIN_VERSION_ghc(8,6,0) HsStarTy _ isUnicode -> do if isUnicode then docLit $ Text.pack "\x2605" -- Unicode star else docLit $ Text.pack "*" XHsType{} -> error "brittany internal error: XHsType" -#endif #if MIN_VERSION_ghc(8,8,0) HsAppKindTy _ ty kind -> do t <- docSharedWrapper layoutType ty @@ -785,18 +645,11 @@ layoutTyVarBndrs :: [LHsTyVarBndr GhcPs] -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] layoutTyVarBndrs = mapM $ \case -#if MIN_VERSION_ghc(8,6,0) (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) (L _ (KindedTyVar _ lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" -#else - (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) -#endif -- there is no specific reason this returns a list instead of a single -- BriDoc node. diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index e9a6979..b33e339 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -407,7 +407,7 @@ todo = error "todo" #if MIN_VERSION_ghc(8,8,0) ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) ghcDL = GHC.dL -#else /* ghc-8.4 8.6 */ +#else /* ghc-8.6 */ ghcDL :: GHC.Located a -> GHC.Located a ghcDL x = x #endif diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 4b4061e..5ee7ed2 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -304,11 +304,8 @@ lines' s = case break (== '\n') s of #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon -#elif MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +#else -- | A method to dismiss NoExt patterns for total matches absurdExt :: HsExtension.NoExt -> a absurdExt = error "cannot construct NoExt" -#else -absurdExt :: () -absurdExt = () #endif diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml deleted file mode 100644 index f925568..0000000 --- a/stack-8.4.3.yaml +++ /dev/null @@ -1,4 +0,0 @@ -resolver: lts-12.12 - -extra-deps: - - ghc-exactprint-0.5.8.1 diff --git a/stack-8.4.3.yaml.lock b/stack-8.4.3.yaml.lock deleted file mode 100644 index b4a4818..0000000 --- a/stack-8.4.3.yaml.lock +++ /dev/null @@ -1,19 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - hackage: ghc-exactprint-0.5.8.1@sha256:f76eed0976b854ce03928796e9cff97769e304618ca99bc0f6cdccab31e539d0,7728 - pantry-tree: - size: 83871 - sha256: 14febc191ef8b0d1f218d13e8db9ed20395f10a5b3d8aa2c0d45869a037420a2 - original: - hackage: ghc-exactprint-0.5.8.1 -snapshots: -- completed: - size: 504336 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/12.yaml - sha256: 11db5c37144d13fe6b56cd511050b4e6ffe988f6edb8e439c2432fc9fcdf50c3 - original: lts-12.12 -- 2.30.2 From 7dedb0c17de82afb8c4653416b63c8afeedc9d63 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 15 Nov 2020 12:07:41 -0500 Subject: [PATCH 365/478] Test against GHC 8.10 --- .github/workflows/ci.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index ae70751..d87e8d9 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -20,6 +20,9 @@ jobs: cabal: - 3.2.0.0 include: + - os: ubuntu-18.04 + ghc: 8.10.2 + cabal: 3.2.0.0 - os: ubuntu-18.04 ghc: 8.6.5 cabal: 3.2.0.0 -- 2.30.2 From c6ad57e33028dcd962a5f81e47a0a91d3ad295fe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 30 Mar 2020 19:59:25 +0200 Subject: [PATCH 366/478] Start implementing sort/uniq on imports/exports --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 123 +++++++++++++----- 1 file changed, 93 insertions(+), 30 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index f2c36de..7e7eff1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -11,15 +11,14 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import GHC ( unLoc - , runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - , Located - ) +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + , runGhc + ) import HsSyn -import Name import HsImpExp import FieldLabel import qualified FastString @@ -70,18 +69,19 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of : hasAnyCommentsBelow x : map hasAnyCommentsBelow ns ) + let sortedNs = List.sortOn wrappedNameToText ns runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq $ [layoutWrapped lie x, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc ns) + ++ intersperse docCommaSep (map nameDoc sortedNs) ++ [docParenR] addAlternative $ docWrapNodeRest lie $ docAddBaseY BrIndentRegular $ docPar (layoutWrapped lie x) - (layoutItems (splitFirstLast ns)) + (layoutItems (splitFirstLast sortedNs)) where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] @@ -137,7 +137,13 @@ layoutAnnAndSepLLIEs :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] - let ieDocs = layoutIE <$> lies + let sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText + $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let ieDocs = layoutIE <$> sortedLies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of FirstLastEmpty -> [] @@ -145,6 +151,39 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] pure $ fmap pure ieCommaDocs -- returned shared nodes + where + mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] + mergeGroup [] = [] + mergeGroup items@[_] = items + mergeGroup items = if + | all isProperIEThing items -> [List.foldl1' thingFolder items] + | otherwise -> items + -- proper means that if it is a ThingWith, it does not contain a wildcard + -- (because I don't know what a wildcard means if it is not already a + -- IEThingAll). + isProperIEThing :: LIE GhcPs -> Bool + isProperIEThing = \case + L _ (IEThingAbs _ _wn) -> True + L _ (IEThingAll _ _wn) -> True + L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True + _ -> False + thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 ( L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) + = L + l + (IEThingWith x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) + ) + thingFolder _ _ = + error "thingFolder should be exhaustive because we have a guard above" + -- Builds a complete layout for the given located -- list of LIEs. The layout provides two alternatives: @@ -163,22 +202,46 @@ layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - runFilteredAlternative $ - case ieDs of - [] -> do - addAlternativeCond (not hasComments) $ - docLit $ Text.pack "()" - addAlternativeCond hasComments $ - docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH:ieDsT) -> do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] + runFilteredAlternative $ case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" + addAlternativeCond hasComments $ docPar + (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH : ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +wrappedNameToText :: LIEWrappedName RdrName -> Text +wrappedNameToText = \case + L _ (IEName n) -> lrdrNameToText n + L _ (IEPattern n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +lieToText :: LIE GhcPs -> Text +lieToText = \case + L _ (IEVar _ wn ) -> wrappedNameToText wn + L _ (IEThingAbs _ wn ) -> wrappedNameToText wn + L _ (IEThingAll _ wn ) -> wrappedNameToText wn + L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn + -- TODO: These _may_ appear in exports! + -- Need to check, and either put them at the top (for module) or do some + -- other clever thing. + L _ (IEModuleContents _ _ ) -> Text.pack "IEModuleContents" + L _ (IEGroup _ _ _ ) -> Text.pack "IEGroup" + L _ (IEDoc _ _ ) -> Text.pack "IEDoc" + L _ (IEDocNamed _ _ ) -> Text.pack "IEDocNamed" + L _ (XIE _ ) -> Text.pack "XIE" -- 2.30.2 From 63de13b0b484588b9d5a15836298101c37af6fbe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:27:33 +0200 Subject: [PATCH 367/478] Fix misworded comment --- src/Language/Haskell/Brittany/Internal.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 1d9266f..09c5d9d 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -647,10 +647,10 @@ layoutBriDoc briDoc = do let state = LayoutState { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we use left here - -- because moveToAnn stuff of the - -- first node needs to do its - -- thing properly. + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. , _lstate_indLevels = [0] , _lstate_indLevelLinger = 0 , _lstate_comments = anns -- 2.30.2 From 614bf3424dcd737d8f50b1a3531ad0744bb36076 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:30:12 +0200 Subject: [PATCH 368/478] Minor refactoring --- .../Haskell/Brittany/Internal/Backend.hs | 12 ++++--- .../Haskell/Brittany/Internal/BackendUtils.hs | 32 +++++++++++-------- .../Brittany/Internal/LayouterBasics.hs | 5 ++- 3 files changed, 29 insertions(+), 20 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 3d29218..234d55e 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -156,7 +156,9 @@ layoutBriDocM = \case BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let allowMTEL = Data.Either.isRight (_lstate_curYOrAddNewline state) + let moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -167,8 +169,8 @@ layoutBriDocM = \case } return mAnn case mAnn of - Nothing -> when allowMTEL $ moveToExactAnn annKey - Just [] -> when allowMTEL $ moveToExactAnn annKey + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace priors @@ -184,7 +186,7 @@ layoutBriDocM = \case -- layoutMoveToIndentCol y layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - when allowMTEL $ moveToExactAnn annKey + moveToExactLocationAction layoutBriDocM bd BDAnnotationKW annKey keyword bd -> do layoutBriDocM bd @@ -373,7 +375,7 @@ briDocIsMultiLine briDoc = rec briDoc BDSetParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 2531794..1253f1a 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -28,6 +28,7 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutMoveToCommentPos , layoutIndentRestorePostComment , moveToExactAnn + , moveToY , ppmMoveToExactLoc , layoutWritePriorComments , layoutWritePostComments @@ -469,20 +470,23 @@ moveToExactAnn annKey = do -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann -- mModify $ \state -> state { _lstate_addNewline = Just x } - mModify $ \state -> - let upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then - _lstate_commentCol state - <|> _lstate_addSepSpace state - <|> Just (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } + moveToY y + +moveToY :: MonadMultiState LayoutState m => Int -> m () +moveToY y = mModify $ \state -> + let upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then + _lstate_commentCol state + <|> _lstate_addSepSpace state + <|> Just (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d40fd6e..770cbdd 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -73,6 +73,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , hasAnyRegularCommentsRest , hasAnnKeywordComment , hasAnnKeyword + , astAnn + , allocNodeIndex ) where @@ -575,7 +577,8 @@ docSeparator = allocateNode BDFSeparator docAnnotationPrior :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm +docAnnotationPrior annKey bdm = + allocateNode . BDFAnnotationPrior annKey =<< bdm docAnnotationKW :: AnnKey -- 2.30.2 From 5a65ed2356983fddd26f14e6f7cc9ce40f3f82ec Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:32:05 +0200 Subject: [PATCH 369/478] Comment out / Explain TODO on unused code --- .../Brittany/Internal/ExactPrintUtils.hs | 97 ++++++++++--------- 1 file changed, 49 insertions(+), 48 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 0273d85..9e22ed2 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -3,7 +3,6 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils ( parseModule , parseModuleFromString - , commentAnnFixTransform , commentAnnFixTransformGlob , extractToplevelAnns , foldedAnnKeys @@ -189,54 +188,56 @@ commentAnnFixTransformGlob ast = do ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns +-- TODO: this is unused by now, but it contains one detail that +-- commentAnnFixTransformGlob does not include: Moving of comments for +-- "RecordUpd"s. +-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransform modul = SYB.everything (>>) genF modul +-- where +-- genF :: Data.Data.Data a => a -> ExactPrint.Transform () +-- genF = (\_ -> return ()) `SYB.extQ` exprF +-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () +-- exprF lexpr@(L _ expr) = case expr of +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #else +-- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordUpd _ _e fs@(_:_) -> +-- #else +-- RecordUpd _e fs@(_:_) _cons _ _ _ -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- _ -> return () -commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () -commentAnnFixTransform modul = SYB.everything (>>) genF modul - where - genF :: Data.Data.Data a => a -> ExactPrint.Transform () - genF = (\_ -> return ()) `SYB.extQ` exprF - exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () - exprF lexpr@(L _ expr) = case expr of -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> -#else - RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> -#endif - moveTrailingComments lexpr (List.last fs) -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecordUpd _ _e fs@(_:_) -> -#else - RecordUpd _e fs@(_:_) _cons _ _ _ -> -#endif - moveTrailingComments lexpr (List.last fs) - _ -> return () - -moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) - => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () -moveTrailingComments astFrom astTo = do - let - k1 = ExactPrint.mkAnnKey astFrom - k2 = ExactPrint.mkAnnKey astTo - moveComments ans = ans' - where - an1 = Data.Maybe.fromJust $ Map.lookup k1 ans - an2 = Data.Maybe.fromJust $ Map.lookup k2 ans - cs1f = ExactPrint.annFollowingComments an1 - cs2f = ExactPrint.annFollowingComments an2 - (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) - $ \case - (ExactPrint.AnnComment com, dp) -> Left (com, dp) - x -> Right x - an1' = an1 - { ExactPrint.annsDP = nonComments - , ExactPrint.annFollowingComments = [] - } - an2' = an2 - { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments - } - ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - - ExactPrint.modifyAnnsT moveComments +-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) +-- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () +-- moveTrailingComments astFrom astTo = do +-- let +-- k1 = ExactPrint.mkAnnKey astFrom +-- k2 = ExactPrint.mkAnnKey astTo +-- moveComments ans = ans' +-- where +-- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans +-- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans +-- cs1f = ExactPrint.annFollowingComments an1 +-- cs2f = ExactPrint.annFollowingComments an2 +-- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) +-- $ \case +-- (ExactPrint.AnnComment com, dp) -> Left (com, dp) +-- x -> Right x +-- an1' = an1 +-- { ExactPrint.annsDP = nonComments +-- , ExactPrint.annFollowingComments = [] +-- } +-- an2' = an2 +-- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments +-- } +-- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans +-- +-- ExactPrint.modifyAnnsT moveComments -- | split a set of annotations in a module into a map from top-level module -- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- 2.30.2 From eb7a4811fda78117040d82862e466b461280e15b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 5 Apr 2020 15:36:46 +0200 Subject: [PATCH 370/478] Implement sorting of import statements --- src/Language/Haskell/Brittany/Internal.hs | 30 ++-- .../Haskell/Brittany/Internal/Layouters/IE.hs | 36 +++-- .../Brittany/Internal/Layouters/Import.hs | 11 +- .../Brittany/Internal/Layouters/Module.hs | 149 +++++++++++++++++- 4 files changed, 193 insertions(+), 33 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 09c5d9d..dd263fa 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -645,24 +645,32 @@ layoutBriDoc briDoc = do anns :: ExactPrint.Anns <- mAsk - let state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + let state = LayoutState { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left -- here because moveToAnn stuff -- of the first node needs to do -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' let remainingComments = - extractAllComments =<< Map.elems (_lstate_comments state') + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 7e7eff1..c27b6c2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -2,6 +2,7 @@ module Language.Haskell.Brittany.Internal.Layouters.IE ( layoutIE , layoutLLIEs , layoutAnnAndSepLLIEs + , SortItemsFlag(..) ) where @@ -17,6 +18,7 @@ import GHC ( unLoc , AnnKeywordId(..) , Located , runGhc + , ModuleName ) import HsSyn import HsImpExp @@ -126,6 +128,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of | otherwise -> name #endif +data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation -- from the located list that actually belongs to the last IE. @@ -134,8 +137,8 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] -layoutAnnAndSepLLIEs llies@(L _ lies) = do + :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] let sortedLies = [ items @@ -143,7 +146,9 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do $ List.sortOn lieToText lies , items <- mergeGroup group ] - let ieDocs = layoutIE <$> sortedLies + let ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of FirstLastEmpty -> [] @@ -157,6 +162,7 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do mergeGroup items@[_] = items mergeGroup items = if | all isProperIEThing items -> [List.foldl1' thingFolder items] + | all isIEVar items -> [List.foldl1' thingFolder items] | otherwise -> items -- proper means that if it is a ThingWith, it does not contain a wildcard -- (because I don't know what a wildcard means if it is not already a @@ -167,7 +173,12 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do L _ (IEThingAll _ _wn) -> True L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True _ -> False + isIEVar :: LIE GhcPs -> Bool + isIEVar = \case + L _ IEVar{} -> True + _ -> False thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs + thingFolder l1@(L _ IEVar{} ) _ = l1 thingFolder l1@(L _ IEThingAll{}) _ = l1 thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder l1 ( L _ IEThingAbs{}) = l1 @@ -198,9 +209,9 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered -layoutLLIEs enableSingleline llies = do - ieDs <- layoutAnnAndSepLLIEs llies +layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline shouldSort llies = do + ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies runFilteredAlternative $ case ieDs of [] -> do @@ -240,8 +251,11 @@ lieToText = \case -- TODO: These _may_ appear in exports! -- Need to check, and either put them at the top (for module) or do some -- other clever thing. - L _ (IEModuleContents _ _ ) -> Text.pack "IEModuleContents" - L _ (IEGroup _ _ _ ) -> Text.pack "IEGroup" - L _ (IEDoc _ _ ) -> Text.pack "IEDoc" - L _ (IEDocNamed _ _ ) -> Text.pack "IEDocNamed" - L _ (XIE _ ) -> Text.pack "XIE" + L _ (IEModuleContents _ n) -> moduleNameToText n + L _ (IEGroup _ _ _ ) -> Text.pack "@IEGroup" + L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" + L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" + L _ (XIE _ ) -> Text.pack "@XIE" + where + moduleNameToText :: Located ModuleName -> Text + moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index bcce106..fc150b9 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -17,6 +17,7 @@ import Name import FieldLabel import qualified FastString import BasicTypes +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.Brittany.Internal.Utils @@ -41,8 +42,8 @@ prepModName :: e -> e prepModName = id #endif -layoutImport :: ToBriDoc ImportDecl -layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of +layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered +layoutImport importD = case importD of #if MIN_VERSION_ghc(8,6,0) ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do #else @@ -92,14 +93,14 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of hasComments <- hasAnyCommentsBelow llies if compact then docAlt - [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True llies] + [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] , let makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True llies) + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) ] else do - ieDs <- layoutAnnAndSepLLIEs llies + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies docWrapNodeRest llies $ docEnsureIndent (BrIndentSpecial hidDocCol) $ case ieDs of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index f899e08..f75fd38 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where #include "prelude.inc" @@ -25,8 +27,16 @@ import Language.Haskell.Brittany.Internal.Utils layoutModule :: ToBriDoc HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule Nothing _ imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) + -- sortedImports <- sortImports imports + -- docLines $ [layoutImport y i | (y, i) <- sortedImports] HsModule (Just n) les imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + -- sortedImports <- sortImports imports let tn = Text.pack $ moduleNameString $ unLoc n allowSingleLineExportList <- mAsk <&> _conf_layout @@ -48,7 +58,7 @@ layoutModule lmod@(L _ mod') = case mod' of , appSep $ docLit tn , docWrapNode lmod $ appSep $ case les of Nothing -> docEmpty - Just x -> layoutLLIEs True x + Just x -> layoutLLIEs True KeepItemsUnsorted x , docSeparator , docLit $ Text.pack "where" ] @@ -57,13 +67,140 @@ layoutModule lmod@(L _ mod') = case mod' of [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) - (docSeq [ docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False x + (docSeq [ + docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x , docSeparator , docLit $ Text.pack "where" ] ) ] ] - : map layoutImport imports + : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] + +data CommentedImport + = EmptyLine + | IndependentComment (Comment, DeltaPos) + | ImportStatement ImportStatementRecord + +instance Show CommentedImport where + show = \case + EmptyLine -> "EmptyLine" + IndependentComment _ -> "IndependentComment" + ImportStatement r -> + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +data ImportStatementRecord = ImportStatementRecord + { commentsBefore :: [(Comment, DeltaPos)] + , commentsAfter :: [(Comment, DeltaPos)] + , importStatement :: ImportDecl HsSyn.GhcPs + } + +instance Show ImportStatementRecord where + show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +transformToCommentedImport + :: [LImportDecl HsSyn.GhcPs] -> ToBriDocM [CommentedImport] +transformToCommentedImport is = do + nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do + annotionMay <- astAnn i + pure (annotionMay, rawImport) + let + convertComment (c, DP (y, x)) = + replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] + accumF + :: [(Comment, DeltaPos)] + -> (Maybe Annotation, ImportDecl HsSyn.GhcPs) + -> ([(Comment, DeltaPos)], [CommentedImport]) + accumF accConnectedComm (annMay, decl) = case annMay of + Nothing -> + ( [] + , [ ImportStatement ImportStatementRecord { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } + ] + ) + Just ann -> + let + blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 + (newAccumulator, priorComments') = + List.span ((== 0) . deltaRow . snd) (annPriorComments ann) + go + :: [(Comment, DeltaPos)] + -> [(Comment, DeltaPos)] + -> ([CommentedImport], [(Comment, DeltaPos)], Int) + go acc [] = ([], acc, 0) + go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) + go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs + go acc ((c1, DP (y, x)) : xs) = + ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine + , (c1, DP (1, x)) : acc + , 0 + ) + (convertedIndependentComments, beforeComments, initialBlanks) = + if blanksBeforeImportDecl /= 0 + then (convertComment =<< priorComments', [], 0) + else go [] (reverse priorComments') + in + ( newAccumulator + , convertedIndependentComments + ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine + ++ [ ImportStatement ImportStatementRecord + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm + , importStatement = decl + } + ] + ) + let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations + pure $ join $ (convertComment =<< finalAcc) : finalList + +sortCommentedImports :: [CommentedImport] -> [CommentedImport] +sortCommentedImports = + unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify + where + unpackImports :: [CommentedImport] -> [CommentedImport] + unpackImports xs = xs >>= \case + l@EmptyLine -> [l] + l@IndependentComment{} -> [l] + ImportStatement r -> + map IndependentComment (commentsBefore r) ++ [ImportStatement r] + mergeGroups + :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] + mergeGroups xs = xs >>= \case + Left x -> [x] + Right y -> ImportStatement <$> y + sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] + sortGroups = + List.sortOn (moduleNameString . unLoc . ideclName . importStatement) + groupify + :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] + groupify cs = go [] cs + where + go [] = \case + (l@EmptyLine : rest) -> Left l : go [] rest + (l@IndependentComment{} : rest) -> Left l : go [] rest + (ImportStatement r : rest) -> go [r] rest + [] -> [] + go acc = \case + (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest + (l@IndependentComment{} : rest) -> + Left l : Right (reverse acc) : go [] rest + (ImportStatement r : rest) -> go (r : acc) rest + [] -> [Right (reverse acc)] + +commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered +commentedImportsToDoc = \case + EmptyLine -> docLitS "" + IndependentComment c -> commentToDoc c + ImportStatement r -> + docSeq + ( layoutImport (importStatement r) + : map commentToDoc (commentsAfter r) + ) + where + commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) -- 2.30.2 From 93ea6542cc8b8b2a9af59602f123e5a03588a281 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 7 Apr 2020 15:01:08 +0200 Subject: [PATCH 371/478] Fix existing tests for new import layouter behaviour --- src-literatetests/10-tests.blt | 71 ++++++++++----------- src-literatetests/14-extensions.blt | 2 +- src-literatetests/30-tests-context-free.blt | 34 +++++----- 3 files changed, 53 insertions(+), 54 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index b1ccfb6..84a638c 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1088,38 +1088,38 @@ import qualified Data.List ( ) import Data.List ( nub ) #test several-elements -import Data.List ( nub - , foldl' +import Data.List ( foldl' , indexElem + , nub ) #test a-ridiculous-amount-of-elements import Test ( Long - , list - , with + , anymore + , fit , items + , line + , list + , not + , onA + , quite + , single , that , will - , not - , quite - , fit - , onA - , single - , line - , anymore + , with ) #test with-things -import Test ( T +import Test ( (+) + , (:!)(..) + , (:*)((:.), T7, t7) + , (:.) + , T , T2() , T3(..) , T4(T4) , T5(T5, t5) , T6((<|>)) - , (+) - , (:.) - , (:.)(..) - , (:.)(T7, (:.), t7) ) #test hiding @@ -1143,56 +1143,55 @@ import Prelude as X ) #test long-module-name-simple -import TestJustShortEnoughModuleNameLikeThisOne ( ) import TestJustAbitToLongModuleNameLikeThisOneIs ( ) +import TestJustShortEnoughModuleNameLikeThisOne ( ) #test long-module-name-as -import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLikeThisOn as T #test long-module-name-hiding -import TestJustShortEnoughModuleNameLike hiding ( ) import TestJustAbitToLongModuleNameLikeTh hiding ( ) +import TestJustShortEnoughModuleNameLike hiding ( ) #test long-module-name-simple-items import MoreThanSufficientlyLongModuleNameWithSome - ( items - , that - , will - , not + ( compact , fit , inA - , compact + , items , layout + , not + , that + , will ) #test long-module-name-hiding-items -import TestJustShortEnoughModuleNameLike hiding ( abc - , def - , ghci - , jklm - ) import TestJustAbitToLongModuleNameLikeTh hiding ( abc , def , ghci , jklm ) +import TestJustShortEnoughModuleNameLike hiding ( abc + , def + , ghci + , jklm + ) #test long-module-name-other -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe - ( ) - -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff - as T import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) import {-# SOURCE #-} safe qualified "qualifiers" A hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff + as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe + ( ) #test import-with-comments -- Test diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index 81dde02..d794e9c 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -78,8 +78,8 @@ module Test (type (++), (++), pattern Foo) where {-# LANGUAGE PatternSynonyms #-} import Test ( type (++) , (++) - , pattern Foo , pattern (:.) + , pattern Foo ) ############################################################################### diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 18649a1..07c94dc 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -753,27 +753,27 @@ import qualified Data.List () import Data.List (nub) #test several-elements -import Data.List (nub, foldl', indexElem) +import Data.List (foldl', indexElem, nub) #test a-ridiculous-amount-of-elements import Test ( Long - , list - , with + , anymore + , fit , items + , line + , list + , not + , onA + , quite + , single , that , will - , not - , quite - , fit - , onA - , single - , line - , anymore + , with ) #test with-things -import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) +import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>))) #test hiding import Test hiding () @@ -796,22 +796,22 @@ import Prelude as X ) #test long-module-name-simple -import TestJustShortEnoughModuleNameLikeThisOne () -import TestJustAbitToLongModuleNameLikeThisOneIs () import MoreThanSufficientlyLongModuleNameWithSome - (items, that, will, not, fit, inA, compact, layout) + (compact, fit, inA, items, layout, not, that, will) +import TestJustAbitToLongModuleNameLikeThisOneIs () +import TestJustShortEnoughModuleNameLikeThisOne () #test long-module-name-as -import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLikeThisOn as T #test long-module-name-hiding -import TestJustShortEnoughModuleNameLike hiding () import TestJustAbitToLongModuleNameLikeTh hiding () +import TestJustShortEnoughModuleNameLike hiding () #test long-module-name-simple-items import MoreThanSufficientlyLongModuleNameWithSome - (items, that, will, not, fit, inA, compact, layout) + (compact, fit, inA, items, layout, not, that, will) #test long-module-name-hiding-items import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) -- 2.30.2 From 1e5b8ada4ea9fa45cf3e36907e848a2f47d435d3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 7 Apr 2020 15:18:27 +0200 Subject: [PATCH 372/478] Fix ghc version compat --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 39 +++++++++++++++++++ .../Brittany/Internal/Layouters/Module.hs | 13 +++++-- 2 files changed, 48 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index c27b6c2..c215fa5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -168,11 +168,19 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). isProperIEThing :: LIE GhcPs -> Bool +#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ isProperIEThing = \case L _ (IEThingAbs _ _wn) -> True L _ (IEThingAll _ _wn) -> True L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True _ -> False +#else /* 8.0 8.2 8.4 */ + isProperIEThing = \case + L _ (IEThingAbs _wn) -> True + L _ (IEThingAll _wn) -> True + L _ (IEThingWith _wn NoIEWildcard _ _) -> True + _ -> False +#endif isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True @@ -183,6 +191,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder l1 ( L _ IEThingAbs{}) = l1 thingFolder (L _ IEThingAbs{}) l2 = l2 +#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l @@ -192,6 +201,16 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do (consItems1 ++ consItems2) (fieldLbls1 ++ fieldLbls2) ) +#else /* 8.0 8.2 8.4 */ + thingFolder (L l (IEThingWith wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ consItems2 fieldLbls2)) + = L + l + (IEThingWith wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) + ) +#endif thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -234,15 +253,21 @@ layoutLLIEs enableSingleline shouldSort llies = do -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. +#if MIN_VERSION_ghc(8,2,0) wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n L _ (IEType n) -> lrdrNameToText n +#else +wrappedNameToText :: Located RdrName -> Text +wrappedNameToText = lrdrNameToText +#endif -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. lieToText :: LIE GhcPs -> Text +#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ lieToText = \case L _ (IEVar _ wn ) -> wrappedNameToText wn L _ (IEThingAbs _ wn ) -> wrappedNameToText wn @@ -256,6 +281,20 @@ lieToText = \case L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" L _ (XIE _ ) -> Text.pack "@XIE" +#else /* 8.0 8.2 8.4 */ +lieToText = \case + L _ (IEVar wn ) -> wrappedNameToText wn + L _ (IEThingAbs wn ) -> wrappedNameToText wn + L _ (IEThingAll wn ) -> wrappedNameToText wn + L _ (IEThingWith wn _ _ _) -> wrappedNameToText wn + -- TODO: These _may_ appear in exports! + -- Need to check, and either put them at the top (for module) or do some + -- other clever thing. + L _ (IEModuleContents n ) -> moduleNameToText n + L _ (IEGroup _ _ ) -> Text.pack "@IEGroup" + L _ (IEDoc _ ) -> Text.pack "@IEDoc" + L _ (IEDocNamed _ ) -> Text.pack "@IEDocNamed" +#endif where moduleNameToText :: Located ModuleName -> Text moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index f75fd38..675acf5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -18,7 +18,12 @@ import FieldLabel import qualified FastString import BasicTypes import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Types + ( DeltaPos(..) + , deltaRow + , commentContents + ) import Language.Haskell.Brittany.Internal.Utils @@ -95,7 +100,7 @@ instance Show CommentedImport where data ImportStatementRecord = ImportStatementRecord { commentsBefore :: [(Comment, DeltaPos)] , commentsAfter :: [(Comment, DeltaPos)] - , importStatement :: ImportDecl HsSyn.GhcPs + , importStatement :: ImportDecl GhcPs } instance Show ImportStatementRecord where @@ -103,7 +108,7 @@ instance Show ImportStatementRecord where (length $ commentsAfter r) transformToCommentedImport - :: [LImportDecl HsSyn.GhcPs] -> ToBriDocM [CommentedImport] + :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] transformToCommentedImport is = do nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do annotionMay <- astAnn i @@ -113,7 +118,7 @@ transformToCommentedImport is = do replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] accumF :: [(Comment, DeltaPos)] - -> (Maybe Annotation, ImportDecl HsSyn.GhcPs) + -> (Maybe Annotation, ImportDecl GhcPs) -> ([(Comment, DeltaPos)], [CommentedImport]) accumF accConnectedComm (annMay, decl) = case annMay of Nothing -> -- 2.30.2 From 71e7f5201435840047ee065d90a29b3c6a345ad1 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 20 Nov 2020 08:52:28 -0500 Subject: [PATCH 373/478] Remove broken test case --- src-literatetests/15-regressions.blt | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index b4a98ab..e288114 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -473,13 +473,6 @@ foo n = case n of 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 #-} -- 2.30.2 From d00387d15694c1db0d1d78ef105af74902dfeaea Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 20 Nov 2020 08:53:08 -0500 Subject: [PATCH 374/478] Remove broken test case --- src-literatetests/30-tests-context-free.blt | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 18649a1..e439ecf 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -1409,14 +1409,6 @@ foo n = case n of 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 #-} -- 2.30.2 From 9efed95d50ce21290540b7fea2d41fbec2fcb680 Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Fri, 20 Nov 2020 23:03:59 +0800 Subject: [PATCH 375/478] Add tests for import sorting --- src-literatetests/10-tests.blt | 23 +++++++++++++++++++++++ src-literatetests/Main.hs | 4 ++++ 2 files changed, 27 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 84a638c..806dd47 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1294,6 +1294,29 @@ import qualified Data.List as L -- Test import Test ( test ) +#test sorted-imports +import Aaa +import Baa + +#test sorted-import-groups +import Zaa +import Zab + +import Aaa +import Baa + +#test sorted-qualified-imports +import Boo +import qualified Zoo + +#test imports-groups-same-module +import Boo ( a ) + +import Boo ( b ) + +#test sorted-imports-nested +import A.B.C +import A.B.D ############################################################################### ############################################################################### diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index b733d62..ae469e3 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -159,6 +159,10 @@ main = do (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] + , [ NormalLine mempty + | _ <- Parsec.try $ Parsec.string "" + , _ <- Parsec.eof + ] ] lineMapper :: Text -> InputLine lineMapper line = case Parsec.runParser specialLineParser () "" line of -- 2.30.2 From c4b6a81b317870501a84ab84d7214fc51844562f Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 23 Nov 2020 08:07:21 -0500 Subject: [PATCH 376/478] List 8.10 support --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index eec9c4c..7828fd2 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.6`, `8.8`. +- Supports GHC versions `8.6`, `8.8`, `8.10`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. -- 2.30.2 From 0a710ab27147d4f7981fe4ca343b43136ee36919 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 23 Nov 2020 08:08:08 -0500 Subject: [PATCH 377/478] Test against 8.10 by default --- .github/workflows/ci.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index d87e8d9..cb91bb8 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -16,12 +16,12 @@ jobs: - ubuntu-18.04 - windows-2019 ghc: - - 8.8.4 + - 8.10.2 cabal: - 3.2.0.0 include: - os: ubuntu-18.04 - ghc: 8.10.2 + ghc: 8.8.4 cabal: 3.2.0.0 - os: ubuntu-18.04 ghc: 8.6.5 -- 2.30.2 From b34210b7391ed43bc678dcb208ebe766b0827fb3 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Wed, 9 Dec 2020 21:30:27 -0500 Subject: [PATCH 378/478] Update Stack configurations --- .travis.yml | 4 ++++ Makefile | 7 ++++++- stack-8.6.5.yaml | 6 +----- stack-8.6.5.yaml.lock | 24 +++++------------------ stack-8.8.4.yaml | 1 + stack-8.8.4.yaml.lock | 12 ++++++++++++ stack.yaml | 11 ++--------- stack.yaml.lock | 44 ++++++++----------------------------------- 8 files changed, 39 insertions(+), 70 deletions(-) create mode 100644 stack-8.8.4.yaml create mode 100644 stack-8.8.4.yaml.lock diff --git a/.travis.yml b/.travis.yml index 19a5ca9..6b223bf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -69,6 +69,10 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} + - env: BUILD=stack ARGS="--stack-yaml stack-8.8.4.yaml" + compiler: ": #stack 8.8.4" + addons: {apt: {packages: [libgmp-dev]}} + - env: BUILD=stack ARGS="--stack-yaml stack-8.6.5.yaml" compiler: ": #stack 8.6.5" addons: {apt: {packages: [libgmp-dev]}} diff --git a/Makefile b/Makefile index ca0a962..2d5b809 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,12 @@ test: .PHONY: test-all test-all: - $(MAKE) test test-8.6.5 + $(MAKE) test test-8.8.4 test-8.6.5 + +.PHONY: test-8.8.4 +test-8.8.4: + echo "test 8.8.4" + stack test --stack-yaml stack-8.8.4.yaml --work-dir .stack-work-8.8.4 .PHONY: test-8.6.5 test-8.6.5: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 2717de3..785b146 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -1,5 +1 @@ -resolver: lts-13.23 - -extra-deps: - - butcher-1.3.2.1 - - multistate-0.8.0.1 +resolver: lts-14.27 diff --git a/stack-8.6.5.yaml.lock b/stack-8.6.5.yaml.lock index a7d341f..e24dcac 100644 --- a/stack-8.6.5.yaml.lock +++ b/stack-8.6.5.yaml.lock @@ -3,24 +3,10 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: -- completed: - hackage: butcher-1.3.2.1@sha256:cf479ea83a08f4f59a482e7c023c70714e7c93c1ccd7d53fe076ad3f1a3d2b8d,3115 - pantry-tree: - size: 1197 - sha256: dc4bd6adc5f8bd3589533659b62567da78b6956d7098e561c0523c60fcaa0406 - original: - hackage: butcher-1.3.2.1 -- completed: - hackage: multistate-0.8.0.1@sha256:496ac087a0df3984045d7460b981d5e868a49e160b60a6555f6799e81e58542d,3700 - pantry-tree: - size: 2143 - sha256: 0136d5fcddee0244c3bc73b4ae1b489134a1dd12a8978f437b2be81e98f5d8bd - original: - hackage: multistate-0.8.0.1 +packages: [] snapshots: - completed: - size: 498398 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/23.yaml - sha256: 63151ca76f39d5cfbd266ce019236459fdda53fbefd2200aedeb33bcc81f808e - original: lts-13.23 + size: 524996 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml + sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 + original: lts-14.27 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml new file mode 100644 index 0000000..d014f95 --- /dev/null +++ b/stack-8.8.4.yaml @@ -0,0 +1 @@ +resolver: lts-16.25 diff --git a/stack-8.8.4.yaml.lock b/stack-8.8.4.yaml.lock new file mode 100644 index 0000000..31befa1 --- /dev/null +++ b/stack-8.8.4.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 533252 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/25.yaml + sha256: 147598b98bdd95ec0409bac125a4f1bff3cd4f8d73334d283d098f66a4bcc053 + original: lts-16.25 diff --git a/stack.yaml b/stack.yaml index 7ff28c9..9989a09 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,11 +1,4 @@ -resolver: lts-13.25 +resolver: nightly-2020-12-09 extra-deps: - - multistate-0.8.0.2 - - butcher-1.3.2.3 - - deque-0.4.2.3 - - strict-list-0.1.4 - - ghc-exactprint-0.6.2 - -packages: - - . + - data-tree-print-0.1.0.2 diff --git a/stack.yaml.lock b/stack.yaml.lock index 6a1ae68..91c9355 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,43 +5,15 @@ packages: - completed: - hackage: multistate-0.8.0.2@sha256:fbb0d8ade9ef73c8ed92488f5804d0ebe75d3a9c24bf53452bc3a4f32b34cb2e,3713 + hackage: data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620 pantry-tree: - size: 2143 - sha256: 1753828d37b456e1e0241766d893b29f385ef7769fa79610f507b747935b77cb + size: 272 + sha256: b8778eb1b16fddb91b2eed2b25f33a89d1e4f7a533160de4ccbf226f82456135 original: - hackage: multistate-0.8.0.2 -- completed: - hackage: butcher-1.3.2.3@sha256:1b8040eddb6da2a05426bf9f6c56b078e629228d64d7d61fb3daa88802487e1b,3262 - pantry-tree: - size: 1197 - sha256: 6bf3a318bd8689bd1fa7a8084c0d96372768d2dc3e30d9aa58d07741ed6816e6 - original: - hackage: butcher-1.3.2.3 -- completed: - hackage: deque-0.4.2.3@sha256:7cc8ddfc77df351ff9c16e838ccdb4a89f055c80a3111e27eba8d90e8edde7d0,1853 - pantry-tree: - size: 807 - sha256: 7f584c71e9e912935f829cb4667411ae3c3048fcd8b935170fb5a45188019403 - original: - hackage: deque-0.4.2.3 -- completed: - hackage: strict-list-0.1.4@sha256:0fa869e2c21b710b7133e8628169f120fe6299342628edd3d5087ded299bc941,1631 - pantry-tree: - size: 340 - sha256: bbb22fd014867dc48697ddd8598d4a9fb03fa2d58ef79bed94f208a9b6d94224 - original: - hackage: strict-list-0.1.4 -- completed: - hackage: ghc-exactprint-0.6.2@sha256:d822f64351e9a8e03d9bad35c8fdf558d30dc396801b396c52b5d5bffaee9108,8368 - pantry-tree: - size: 85384 - sha256: d904de9c01e58bfa091d7caa09e0423e9d2932b7b3490c4d83140731f4473877 - original: - hackage: ghc-exactprint-0.6.2 + hackage: data-tree-print-0.1.0.2 snapshots: - completed: - size: 499461 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/25.yaml - sha256: aed98969628e20615e96b06083c933c7e3354ae56b08b75e607a26569225d6c0 - original: lts-13.25 + size: 556768 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/12/9.yaml + sha256: bca31ebf05f842be9dd24410eca84f296da1860369a82eb7466f447a76cca762 + original: nightly-2020-12-09 -- 2.30.2 From 6453e218edd77f8e56e7edfd0132885f70d3c044 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Wed, 9 Dec 2020 21:30:58 -0500 Subject: [PATCH 379/478] Publish from GHC 8.10.2 --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index cb91bb8..e7c3add 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -50,7 +50,7 @@ jobs: with: path: output/brittany* name: brittany-${{ matrix.os }}-ghc-${{ matrix.ghc }}-${{ github.sha }} - - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.8.4' + - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.10.2' uses: actions/upload-artifact@v2 with: path: dist-newstyle/sdist/brittany-*.tar.gz -- 2.30.2 From 1b74b4274c64bd1c3518a216290263409efdf769 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Wed, 9 Dec 2020 21:56:28 -0500 Subject: [PATCH 380/478] Version 0.13.0.0 --- ChangeLog.md | 6 ++++++ brittany.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 41c1825..77ecfe6 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for brittany +## 0.13.0.0 -- December 2020 + +* #324: Added support for GHC 8.10. + * Dropped support for GHC 8.4, 8.2, and 8.0. + * Thanks @jneira, @bubba, @infinity0, and @expipiplus1! + ## 0.12.2.0 -- November 2020 * #207: Fix newtype indent in associated type family. diff --git a/brittany.cabal b/brittany.cabal index cd541fb..cbc0631 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.12.2.0 +version: 0.13.0.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 0b0c6d65ca583ee6463679065acf6641a08eab2b Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Fri, 20 Nov 2020 23:17:29 +0800 Subject: [PATCH 381/478] Simplify Nix expressions This uses `developPackage` from `nixpkgs` to generate the derivation Also add CI for nix build --- .github/workflows/ci.yaml | 8 ++++++ README.md | 16 +++++++++++- default.nix | 52 ++++++++++++--------------------------- pkgs.nix | 5 ---- release.nix | 5 ---- shell.nix | 13 ---------- 6 files changed, 39 insertions(+), 60 deletions(-) delete mode 100644 pkgs.nix delete mode 100644 release.nix delete mode 100644 shell.nix diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e7c3add..466e206 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -56,3 +56,11 @@ jobs: path: dist-newstyle/sdist/brittany-*.tar.gz name: brittany-${{ github.sha }}.tar.gz - run: cabal check + + + nix: + runs-on: ubuntu-latest + steps: + - uses: cachix/install-nix-action@v12 + - uses: actions/checkout@v2 + - run: nix-build diff --git a/README.md b/README.md index 7828fd2..465e215 100644 --- a/README.md +++ b/README.md @@ -70,7 +70,7 @@ log the size of the input, but _not_ the full input/output of requests.) - via `nix`: ~~~.sh - nix build -f release.nix # or 'nix-build -f release.nix' + nix build nix-env -i ./result ~~~ @@ -102,6 +102,20 @@ log the size of the input, but _not_ the full input/output of requests.) aura -A brittany ~~~~ +# Development tips + +## Run a hoogle server + +To host a local Hoogle server with all of Brittany's dependencies run: + +```sh +echo brittany.cabal | + $(nix-build '' --no-link -A entr)/bin/entr -r -- \ + sh -c "nix-shell --run 'hoogle server --local'" +``` + +This will watch `brittany.cabal` for changes and restart the server when new dependencies are added there. + # Editor Integration #### Sublime text diff --git a/default.nix b/default.nix index 296987a..ed3dcca 100644 --- a/default.nix +++ b/default.nix @@ -1,38 +1,18 @@ -{ mkDerivation, aeson, base, butcher, bytestring, cmdargs -, containers, czipwith, data-tree-print, deepseq, directory, extra -, filepath, ghc, ghc-boot-th, ghc-exactprint, ghc-paths, hspec -, monad-memo, mtl, multistate, neat-interpolation, parsec, pretty -, random, safe, semigroups, stdenv, strict, syb, text, transformers -, uniplate, unsafe, yaml +{ nixpkgsSrc ? builtins.fetchTarball { + url = + "https://github.com/nixos/nixpkgs/archive/069f183f16c3ea5d4b6e7625433b92eba77534f7.tar.gz"; # nixos-unstable + sha256 = "1by9rqvr2k6iz2yipf89yaj254yicpwq384ijgyy8p71lfxbbww2"; +}, pkgs ? import nixpkgsSrc { }, compiler ? null, forShell ? pkgs.lib.inNixShell }: -mkDerivation { - pname = "brittany"; - version = "0.11.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson base butcher bytestring cmdargs containers czipwith - data-tree-print deepseq directory extra filepath ghc ghc-boot-th - ghc-exactprint ghc-paths monad-memo mtl multistate - neat-interpolation pretty random safe semigroups strict syb text - transformers uniplate unsafe yaml - ]; - executableHaskellDepends = [ - aeson base butcher bytestring cmdargs containers czipwith - data-tree-print deepseq directory extra filepath ghc ghc-boot-th - ghc-exactprint ghc-paths monad-memo mtl multistate - neat-interpolation pretty safe semigroups strict syb text - transformers uniplate unsafe yaml - ]; - testHaskellDepends = [ - aeson base butcher bytestring cmdargs containers czipwith - data-tree-print deepseq directory extra filepath ghc ghc-boot-th - ghc-exactprint ghc-paths hspec monad-memo mtl multistate - neat-interpolation parsec pretty safe semigroups strict syb text - transformers uniplate unsafe yaml - ]; - homepage = "https://github.com/lspitzner/brittany/"; - description = "Haskell source code formatter"; - license = stdenv.lib.licenses.agpl3; + +let + haskellPackages = if compiler == null then + pkgs.haskellPackages + else + pkgs.haskell.packages.${compiler}; + +in haskellPackages.developPackage { + name = "brittany"; + root = pkgs.nix-gitignore.gitignoreSource [ ] ./.; + returnShellEnv = forShell; } diff --git a/pkgs.nix b/pkgs.nix deleted file mode 100644 index 76cbbb8..0000000 --- a/pkgs.nix +++ /dev/null @@ -1,5 +0,0 @@ -{ - url = "https://github.com/nixos/nixpkgs.git"; - ref = "release-18.09"; - rev = "b9fa31cea0e119ecf1867af4944ddc2f7633aacd"; -} diff --git a/release.nix b/release.nix deleted file mode 100644 index b37b2ce..0000000 --- a/release.nix +++ /dev/null @@ -1,5 +0,0 @@ -{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} -, compiler ? "ghc822" -}: - -pkgs.haskell.packages.${compiler}.callPackage ./shell.nix {} diff --git a/shell.nix b/shell.nix deleted file mode 100644 index 5c0ccfe..0000000 --- a/shell.nix +++ /dev/null @@ -1,13 +0,0 @@ -{ pkgs ? import (fetchGit (import ./pkgs.nix)) {} -, compiler ? "ghc822" -}: - -pkgs.haskell.packages.${compiler}.developPackage { - root = ./.; - name = "brittany"; - overrides = with pkgs.haskell.lib; self: super: { - }; - source-overrides = { - ghc-exactprint = "0.5.8.0"; - }; -} -- 2.30.2 From 8a88e1062520cd8fef5c5a1eda4f35ec39944f6c Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Fri, 11 Dec 2020 17:08:57 +0800 Subject: [PATCH 382/478] Drop CPP for no-longer-supported GHC versions --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 40 +------------------ 1 file changed, 1 insertion(+), 39 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 8405d4d..2a722d1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -134,19 +134,11 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). isProperIEThing :: LIE GhcPs -> Bool -#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ isProperIEThing = \case L _ (IEThingAbs _ _wn) -> True L _ (IEThingAll _ _wn) -> True L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True _ -> False -#else /* 8.0 8.2 8.4 */ - isProperIEThing = \case - L _ (IEThingAbs _wn) -> True - L _ (IEThingAll _wn) -> True - L _ (IEThingWith _wn NoIEWildcard _ _) -> True - _ -> False -#endif isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True @@ -157,7 +149,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder l1 ( L _ IEThingAbs{}) = l1 thingFolder (L _ IEThingAbs{}) l2 = l2 -#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l @@ -167,16 +158,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do (consItems1 ++ consItems2) (fieldLbls1 ++ fieldLbls2) ) -#else /* 8.0 8.2 8.4 */ - thingFolder (L l (IEThingWith wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ consItems2 fieldLbls2)) - = L - l - (IEThingWith wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) - ) -#endif thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -219,21 +200,16 @@ layoutLLIEs enableSingleline shouldSort llies = do -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. -#if MIN_VERSION_ghc(8,2,0) wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n L _ (IEType n) -> lrdrNameToText n -#else -wrappedNameToText :: Located RdrName -> Text -wrappedNameToText = lrdrNameToText -#endif + -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. lieToText :: LIE GhcPs -> Text -#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */ lieToText = \case L _ (IEVar _ wn ) -> wrappedNameToText wn L _ (IEThingAbs _ wn ) -> wrappedNameToText wn @@ -247,20 +223,6 @@ lieToText = \case L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" L _ (XIE _ ) -> Text.pack "@XIE" -#else /* 8.0 8.2 8.4 */ -lieToText = \case - L _ (IEVar wn ) -> wrappedNameToText wn - L _ (IEThingAbs wn ) -> wrappedNameToText wn - L _ (IEThingAll wn ) -> wrappedNameToText wn - L _ (IEThingWith wn _ _ _) -> wrappedNameToText wn - -- TODO: These _may_ appear in exports! - -- Need to check, and either put them at the top (for module) or do some - -- other clever thing. - L _ (IEModuleContents n ) -> moduleNameToText n - L _ (IEGroup _ _ ) -> Text.pack "@IEGroup" - L _ (IEDoc _ ) -> Text.pack "@IEDoc" - L _ (IEDocNamed _ ) -> Text.pack "@IEDocNamed" -#endif where moduleNameToText :: Located ModuleName -> Text moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) -- 2.30.2 From 8d4e03c53e429ee45a20213df98dc0799ba8503d Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 11 Dec 2020 10:47:25 -0500 Subject: [PATCH 383/478] Remove Travis CI --- .travis.yml | 231 +--------------------------------------------------- 1 file changed, 1 insertion(+), 230 deletions(-) diff --git a/.travis.yml b/.travis.yml index 6b223bf..ee15e0e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,230 +1 @@ -# Use new container infrastructure to enable caching -sudo: false - -# Do not choose a language; we provide our own build tools. -language: generic - -# Caching so the next build will be fast too. -cache: - directories: - - $HOME/.cabsnap - - $HOME/.cabal/packages - - $HOME/.stack - - $HOME/.cabal/store - # alternatively: - #- $HOME/.stack/bin - #- $HOME/.stack/precompiled - #- $HOME/.stack/programs - #- $HOME/.stack/setup-exe-cache - #- $HOME/.stack/snapshots - -before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - -# The different configurations we want to test. We have -# - BUILD=cabal which uses cabal-install(<2.0) -# - BUILD=canew which uses cabal-install 2.0 "new-build" -# - BUILD=stack which uses Stack. -# -# We set the compiler values here to tell Travis to use a different -# cache file per set of arguments. -# -# If you need to have different apt packages for each combination in the -# matrix, you can use a line such as: -# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} -matrix: - include: - - ##### OSX test via stack ##### - - ##### CABAL ##### - - - env: BUILD=cabal GHCVER=8.6.5 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal 8.6.5" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.6.5,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # Build with the newest GHC and cabal-install. This is an accepted failure, - # see below. - #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC HEAD" - # addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - ##### CANEW ##### - - - env: BUILD=canew GHCVER=8.8.1 CABALVER=3.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #cabal new 8.8.1" - addons: {apt: {packages: [cabal-install-3.0,ghc-8.8.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - ##### STACK ##### - - # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS - # variable, such as using --stack-yaml to point to a different file. - - env: BUILD=stack ARGS="" - compiler: ": #stack default" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=stack ARGS="--stack-yaml stack-8.8.4.yaml" - compiler: ": #stack 8.8.4" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=stack ARGS="--stack-yaml stack-8.6.5.yaml" - compiler: ": #stack 8.6.5" - addons: {apt: {packages: [libgmp-dev]}} - - # Nightly builds are allowed to fail - - env: BUILD=stack ARGS="--resolver nightly" - compiler: ": #stack nightly" - addons: {apt: {packages: [libgmp-dev]}} - - allow_failures: - #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - - env: BUILD=stack ARGS="--resolver nightly" - - env: BUILD=stack ARGS="" - -before_install: -# Using compiler above sets CC to an invalid value, so unset it -- unset CC - -# We want to always allow newer versions of packages when building on GHC HEAD -- CABALARGS="" -- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi - -# Download and unpack the stack executable -- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH -- mkdir -p ~/.local/bin -- | - if [ `uname` = "Darwin" ] - then - travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin - else - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - fi - - # Use the more reliable S3 mirror of Hackage - #mkdir -p $HOME/.cabal - #echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - #echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config - - #if [ "$CABALVER" != "1.16" ] - #then - # echo 'jobs: $ncpus' >> $HOME/.cabal/config - #fi -- PKGNAME='brittany' -- JOBS='1' -- | - function better_wait() { - date - time "$@" & # send the long living command to background! - - set +x - MINUTES=0 - LIMIT=30 - while kill -0 $! >/dev/null 2>&1; do - echo -n -e " \b" # never leave evidences! - - if [ $MINUTES == $LIMIT ]; then - break; - fi - - MINUTES=$((MINUTES+1)) - - sleep 60 - done - wait $! - set -x - } - -install: -- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" -- if [ -f configure.ac ]; then autoreconf -i; fi -- | - set -ex - case "$BUILD" in - stack) - stack -j$JOBS --no-terminal --install-ghc $ARGS test --bench --only-dependencies --flag brittany:brittany-test-perf - ;; - cabal*) - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; - then - zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >$HOME/.cabal/packages/hackage.haskell.org/00-index.tar; - fi - travis_retry cabal update -v - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt - - # check whether current requested install-plan matches cached package-db snapshot - if diff -u $HOME/.cabsnap/installplan.txt installplan.txt; - then - echo "cabal build-cache HIT"; - rm -rfv .ghc; - cp -a $HOME/.cabsnap/ghc $HOME/.ghc; - cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; - else - echo "cabal build-cache MISS"; - rm -rf $HOME/.cabsnap; - mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M700M -RTS"; - fi - - # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; - then - echo "snapshotting package-db to build-cache"; - mkdir $HOME/.cabsnap; - cp -a $HOME/.ghc $HOME/.cabsnap/ghc; - cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; - fi - ;; - canew) - cabal --version - travis_retry cabal update -v - echo 'packages: .' > cabal.project - echo 'package brittany' > cabal.project.local - echo ' ghc-options: -Werror -with-rtsopts=-N1 -j1 +RTS -M700M -RTS' >> cabal.project.local - echo ' flags: +brittany-test-perf' >> cabal.project.local - rm -f cabal.project.freeze - cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep - cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep - ;; - esac - set +ex - -script: -- | - set -ex - case "$BUILD" in - stack) - better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M700M -RTS -Werror -with-rtsopts=-N1" --flag brittany:brittany-test-perf - ;; - cabal) - if [ -f configure.ac ]; then autoreconf -i; fi - cabal configure --enable-tests --enable-benchmarks -v --flags="brittany-test-perf" # -v2 provides useful information for debugging - better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M700M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) - time cabal test --ghc-options="-with-rtsopts=-N1" - ;; - cabaldist) - # cabal check - cabal sdist # tests that a source-distribution can be generated - - # Check that the resulting source distribution can be built & installed. - # If there are no other `.tar.gz` files in `dist`, this can be even simpler: - # `cabal install --force-reinstalls dist/*-*.tar.gz` - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && - (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M700M -RTS") - ;; - canew) - better_wait cabal new-build -j$JOBS --disable-tests --disable-benchmarks - better_wait cabal new-build -j$JOBS --enable-tests --enable-benchmarks - time cabal new-test -j1 - ;; - esac - set +ex +language: minimal -- 2.30.2 From a13ad1b9da9772caec1024586e70475ff0ef0c48 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 11 Dec 2020 11:40:48 -0500 Subject: [PATCH 384/478] Version 0.13.1.0 --- ChangeLog.md | 4 ++++ brittany.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 77ecfe6..e535bc9 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for brittany +## 0.13.1.0 -- December 2020 + +* #330: Started sorting imports. Thanks @expipiplus1! + ## 0.13.0.0 -- December 2020 * #324: Added support for GHC 8.10. diff --git a/brittany.cabal b/brittany.cabal index cbc0631..a33136b 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.13.0.0 +version: 0.13.1.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From e8c4855cd35773629e52815623a8fee1b9ac106f Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Wed, 16 Dec 2020 01:51:33 +0800 Subject: [PATCH 385/478] Allow random 1.2 Builds fine and all tests pass here. --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index a33136b..d3fc87f 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -120,7 +120,7 @@ library { , czipwith >=1.0.1.0 && <1.1 , ghc-boot-th >=8.6.1 && <8.11 , filepath >=1.4.1.0 && <1.5 - , random >= 1.1 && <1.2 + , random >= 1.1 && <1.3 } default-extensions: { CPP -- 2.30.2 From 9658653ab9127ffa6bca3ae8abe404a7c2ad924d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Anton=20Str=C3=B6mkvist?= Date: Sat, 2 Jan 2021 09:16:57 +0100 Subject: [PATCH 386/478] Update ArchLinux installation instructions Brittany is in the community repo now, and no longer requires AUR --- README.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 465e215..5ee23ac 100644 --- a/README.md +++ b/README.md @@ -96,10 +96,9 @@ log the size of the input, but _not_ the full input/output of requests.) (TODO: These instructions are more confusing than helpful. I am inclined to just remove them.) -- on ArchLinux via [the brittany AUR package](https://aur.archlinux.org/packages/brittany/) - using `aura`: +- on ArchLinux: ~~~~.sh - aura -A brittany + pacman -S haskell-brittany ~~~~ # Development tips -- 2.30.2 From 256a30cdf8a022351ac84bd59731d5195332835f Mon Sep 17 00:00:00 2001 From: maralorn Date: Fri, 26 Feb 2021 14:29:00 +0100 Subject: [PATCH 387/478] Update ghc-exactprint upper bound --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index d3fc87f..8b74e71 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -94,7 +94,7 @@ library { { base >=4.12 && <4.15 , ghc >=8.6.1 && <8.11 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.6.4 + , ghc-exactprint >=0.5.8 && <0.6.5 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.1 && <2.3 -- 2.30.2 From 1a9863160b0316921f911ce54707cb0618bae4c7 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 26 Feb 2021 08:52:58 -0500 Subject: [PATCH 388/478] Update ChangeLog.md --- ChangeLog.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index e535bc9..3f1ded5 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for brittany +## 0.13.1.1 -- February 2021 + +* #333: Allowed random 1.2. Thanks @felixonmars! +* #334: Updated Arch install instructions. Thanks @ahstro! +* #343: Allowed ghc-exactprint 0.6.4. Thanks @maralorn! + ## 0.13.1.0 -- December 2020 * #330: Started sorting imports. Thanks @expipiplus1! -- 2.30.2 From 4d064db674203626fe5011d10874fcbc335ec9b1 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 26 Feb 2021 08:53:28 -0500 Subject: [PATCH 389/478] Version 0.13.1.1 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 8b74e71..6502e70 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.13.1.0 +version: 0.13.1.1 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 7a7ea6c40dc647f8a68e43a7f822babf03cb85a3 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Sat, 15 May 2021 06:07:49 +0800 Subject: [PATCH 390/478] Allow hspec 2.8 All tests are passing. --- brittany.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 6502e70..f657625 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -199,7 +199,7 @@ test-suite unittests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.8 + , hspec >=2.4.1 && <2.9 } main-is: TestMain.hs other-modules: TestUtils @@ -270,7 +270,7 @@ test-suite littests , cmdargs , czipwith , ghc-boot-th - , hspec >=2.4.1 && <2.8 + , hspec >=2.4.1 && <2.9 , filepath , parsec >=3.1.11 && <3.2 } @@ -314,7 +314,7 @@ test-suite libinterfacetests , base , text , transformers - , hspec >=2.4.1 && <2.8 + , hspec >=2.4.1 && <2.9 } main-is: Main.hs other-modules: -- 2.30.2 From 50f053cc2c1d38841c9415313409a23320e6138d Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Tue, 18 May 2021 08:33:51 -0400 Subject: [PATCH 391/478] Update ChangeLog.md --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 3f1ded5..c96c598 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for brittany +## 0.13.1.2 -- May 2021 + +* #347: Allowed hspec 2.8. Thanks @felixonmars! + ## 0.13.1.1 -- February 2021 * #333: Allowed random 1.2. Thanks @felixonmars! -- 2.30.2 From 434f9f8e49b847ef3e648672c5564b6dd0d3be67 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Tue, 18 May 2021 08:34:18 -0400 Subject: [PATCH 392/478] Version 0.13.1.2 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index f657625..fa058f4 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.13.1.1 +version: 0.13.1.2 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From ee5be0735bfdd5dec79c1ddf16d50b67027d47f4 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 30 Oct 2021 10:00:46 -0400 Subject: [PATCH 393/478] Set up development container --- .devcontainer/Dockerfile | 30 ++++++++++++++++++++++++++++++ .devcontainer/devcontainer.json | 6 ++++++ 2 files changed, 36 insertions(+) create mode 100644 .devcontainer/Dockerfile create mode 100644 .devcontainer/devcontainer.json diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile new file mode 100644 index 0000000..ef657c5 --- /dev/null +++ b/.devcontainer/Dockerfile @@ -0,0 +1,30 @@ +ARG UBUNTU_TAG=20.04 +FROM ubuntu:"$UBUNTU_TAG" + +ENV LANG=C.UTF-8 +RUN \ + apt-get update && \ + apt-get install --assume-yes curl gcc git libgmp-dev libtinfo-dev make sudo + +ARG GHCUP_VERSION=0.1.17.3 +RUN \ + curl --output /usr/local/bin/ghcup "https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION" && \ + chmod +x /usr/local/bin/ghcup && \ + ghcup --version + +ARG USER_NAME=haskell +RUN \ + useradd --create-home --shell "$( which bash )" "$USER_NAME" && \ + echo "$USER_NAME ALL=(ALL) NOPASSWD: ALL" | tee "/etc/sudoers.d/$USER_NAME" +USER "$USER_NAME" +ENV PATH="/home/$USER_NAME/.cabal/bin:/home/$USER_NAME/.ghcup/bin:$PATH" + +ARG GHC_VERSION=9.2.1 +RUN \ + ghcup install ghc "$GHC_VERSION" --set && \ + ghc --version + +ARG CABAL_VERSION=3.6.2.0 +RUN \ + ghcup install cabal "$CABAL_VERSION" --set && \ + cabal --version diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json new file mode 100644 index 0000000..582acff --- /dev/null +++ b/.devcontainer/devcontainer.json @@ -0,0 +1,6 @@ +{ + "build": { + "dockerfile": "Dockerfile" + }, + "postCreateCommand": "cabal update" +} -- 2.30.2 From 9940aa4ae540b755f5efafb3b2a4118ba6eaafa8 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 30 Oct 2021 14:48:37 +0000 Subject: [PATCH 394/478] Get a working build plan --- .devcontainer/Dockerfile | 7 +++++- .github/workflows/ci.yaml | 48 +++++++++++++-------------------------- .gitignore | 3 ++- brittany.cabal | 6 ++--- cabal.project | 12 ++++++++++ 5 files changed, 39 insertions(+), 37 deletions(-) create mode 100644 cabal.project diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index ef657c5..2328b4d 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -19,7 +19,7 @@ RUN \ USER "$USER_NAME" ENV PATH="/home/$USER_NAME/.cabal/bin:/home/$USER_NAME/.ghcup/bin:$PATH" -ARG GHC_VERSION=9.2.1 +ARG GHC_VERSION=9.0.1 RUN \ ghcup install ghc "$GHC_VERSION" --set && \ ghc --version @@ -28,3 +28,8 @@ ARG CABAL_VERSION=3.6.2.0 RUN \ ghcup install cabal "$CABAL_VERSION" --set && \ cabal --version + +ARG HLS_VERSION=1.4.0 +RUN \ + ghcup install hls "$HLS_VERSION" --set && \ + haskell-language-server-wrapper --version diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 466e206..0189cb7 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -2,38 +2,34 @@ name: CI on: pull_request: branches: - - master + - main push: branches: - - master + - main jobs: build: strategy: fail-fast: false matrix: os: - - macos-10.15 - - ubuntu-18.04 + - macos-11 + - ubuntu-20.04 - windows-2019 ghc: - - 8.10.2 + - 9.0.1 cabal: - - 3.2.0.0 - include: - - os: ubuntu-18.04 - ghc: 8.8.4 - cabal: 3.2.0.0 - - os: ubuntu-18.04 - ghc: 8.6.5 - cabal: 3.2.0.0 + - 3.6.2.0 runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 + - run: mkdir artifact + - run: mkdir artifact/${{ matrix.os }} - id: setup-haskell - uses: actions/setup-haskell@v1 + uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} + - run: cabal configure --enable-tests - run: cabal freeze - run: cat cabal.project.freeze - uses: actions/cache@v2 @@ -43,24 +39,12 @@ jobs: restore-keys: | ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}- ${{ matrix.os }}-${{ matrix.ghc }}- + - run: cabal build + - run: cabal install --installdir artifact/${{ matrix.os }} --install-method copy - run: cabal test --test-show-details direct - - run: cabal install --installdir output --install-method copy - - run: strip output/brittany* + - run: cabal check + - run: cabal sdist --output-dir artifact/${{ matrix.os }} - uses: actions/upload-artifact@v2 with: - path: output/brittany* - name: brittany-${{ matrix.os }}-ghc-${{ matrix.ghc }}-${{ github.sha }} - - if: matrix.os == 'ubuntu-18.04' && matrix.ghc == '8.10.2' - uses: actions/upload-artifact@v2 - with: - path: dist-newstyle/sdist/brittany-*.tar.gz - name: brittany-${{ github.sha }}.tar.gz - - run: cabal check - - - nix: - runs-on: ubuntu-latest - steps: - - uses: cachix/install-nix-action@v12 - - uses: actions/checkout@v2 - - run: nix-build + path: artifact + name: brittany-${{ github.sha }} diff --git a/.gitignore b/.gitignore index 4cdb828..f04e47c 100644 --- a/.gitignore +++ b/.gitignore @@ -10,7 +10,8 @@ local/ .cabal-sandbox/ .stack-work/ cabal.sandbox.config -cabal.project.local +cabal.project.local* +cabal.project.freeze .ghc.environment.* result .stack-work* diff --git a/brittany.cabal b/brittany.cabal index fa058f4..f533c7f 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -91,8 +91,8 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.12 && <4.15 - , ghc >=8.6.1 && <8.11 + { base >=4.12 && <4.16 + , ghc >=8.6.1 && <8.11 || >=9.0.1 && <9.1 , ghc-paths >=0.1.0.9 && <0.2 , ghc-exactprint >=0.5.8 && <0.6.5 , transformers >=0.5.2.0 && <0.6 @@ -118,7 +118,7 @@ library { , semigroups >=0.18.2 && <0.20 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.6.1 && <8.11 + , ghc-boot-th >=8.6.1 && <8.11 || >=9.0.1 && <9.1 , filepath >=1.4.1.0 && <1.5 , random >= 1.1 && <1.3 } diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..6d724ea --- /dev/null +++ b/cabal.project @@ -0,0 +1,12 @@ +packages: . + +allow-newer: + , butcher:base + , data-tree-print:base + , multistate:base + +-- https://github.com/lspitzner/czipwith/pull/2 +source-repository-package + type: git + location: https://github.com/mithrandi/czipwith + tag: b6245884ae83e00dd2b5261762549b37390179f8 -- 2.30.2 From abba8668f70a8f501c7a8f47c3a5383ddec34dcf Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 30 Oct 2021 14:49:03 +0000 Subject: [PATCH 395/478] Sort dependencies --- brittany.cabal | 48 ++++++++++++++++++++++++------------------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index f533c7f..c36814a 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -92,35 +92,35 @@ library { } build-depends: { base >=4.12 && <4.16 - , ghc >=8.6.1 && <8.11 || >=9.0.1 && <9.1 - , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.8 && <0.6.5 - , transformers >=0.5.2.0 && <0.6 - , containers >=0.5.7.1 && <0.7 - , mtl >=2.2.1 && <2.3 - , text >=1.2 && <1.3 - , multistate >=0.7.1.1 && <0.9 - , syb >=0.6 && <0.8 - , data-tree-print - , pretty >=1.1.3.3 && <1.2 - , bytestring >=0.10.8.1 && <0.11 - , directory >=1.2.6.2 && <1.4 - , butcher >=1.3.1 && <1.4 - , yaml >=0.8.18 && <0.12 , aeson >=1.0.1.0 && <1.6 - , extra >=1.4.10 && <1.8 - , uniplate >=1.6.12 && <1.7 - , strict >=0.3.2 && <0.5 - , monad-memo >=0.4.1 && <0.6 - , unsafe >=0.0 && <0.1 - , safe >=0.3.9 && <0.4 - , deepseq >=1.4.2.0 && <1.5 - , semigroups >=0.18.2 && <0.20 + , butcher >=1.3.1 && <1.4 + , bytestring >=0.10.8.1 && <0.11 , cmdargs >=0.10.14 && <0.11 + , containers >=0.5.7.1 && <0.7 , czipwith >=1.0.1.0 && <1.1 - , ghc-boot-th >=8.6.1 && <8.11 || >=9.0.1 && <9.1 + , data-tree-print + , deepseq >=1.4.2.0 && <1.5 + , directory >=1.2.6.2 && <1.4 + , extra >=1.4.10 && <1.8 , filepath >=1.4.1.0 && <1.5 + , ghc >=8.6.1 && <8.11 || >=9.0.1 && <9.1 + , ghc-boot-th >=8.6.1 && <8.11 || >=9.0.1 && <9.1 + , ghc-exactprint >=0.5.8 && <0.6.5 + , ghc-paths >=0.1.0.9 && <0.2 + , monad-memo >=0.4.1 && <0.6 + , mtl >=2.2.1 && <2.3 + , multistate >=0.7.1.1 && <0.9 + , pretty >=1.1.3.3 && <1.2 , random >= 1.1 && <1.3 + , safe >=0.3.9 && <0.4 + , semigroups >=0.18.2 && <0.20 + , strict >=0.3.2 && <0.5 + , syb >=0.6 && <0.8 + , text >=1.2 && <1.3 + , transformers >=0.5.2.0 && <0.6 + , uniplate >=1.6.12 && <1.7 + , unsafe >=0.0 && <0.1 + , yaml >=0.8.18 && <0.12 } default-extensions: { CPP -- 2.30.2 From 7bd98ffb1c0c3265cba0af857ad1a04fb9d3a0dc Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 30 Oct 2021 15:02:35 +0000 Subject: [PATCH 396/478] Upgrade dependencies and tighten bounds --- brittany.cabal | 62 +++++++++++++++++++++++++------------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index c36814a..000c2bc 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -16,7 +16,7 @@ copyright: Copyright (C) 2016-2019 Lennart Spitzner Copyright (C) 2019 PRODA LTD category: Language build-type: Simple -cabal-version: 1.18 +cabal-version: 2.0 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues extra-doc-files: { @@ -91,36 +91,36 @@ library { -fno-warn-redundant-constraints } build-depends: - { base >=4.12 && <4.16 - , aeson >=1.0.1.0 && <1.6 - , butcher >=1.3.1 && <1.4 - , bytestring >=0.10.8.1 && <0.11 - , cmdargs >=0.10.14 && <0.11 - , containers >=0.5.7.1 && <0.7 - , czipwith >=1.0.1.0 && <1.1 - , data-tree-print - , deepseq >=1.4.2.0 && <1.5 - , directory >=1.2.6.2 && <1.4 - , extra >=1.4.10 && <1.8 - , filepath >=1.4.1.0 && <1.5 - , ghc >=8.6.1 && <8.11 || >=9.0.1 && <9.1 - , ghc-boot-th >=8.6.1 && <8.11 || >=9.0.1 && <9.1 - , ghc-exactprint >=0.5.8 && <0.6.5 - , ghc-paths >=0.1.0.9 && <0.2 - , monad-memo >=0.4.1 && <0.6 - , mtl >=2.2.1 && <2.3 - , multistate >=0.7.1.1 && <0.9 - , pretty >=1.1.3.3 && <1.2 - , random >= 1.1 && <1.3 - , safe >=0.3.9 && <0.4 - , semigroups >=0.18.2 && <0.20 - , strict >=0.3.2 && <0.5 - , syb >=0.6 && <0.8 - , text >=1.2 && <1.3 - , transformers >=0.5.2.0 && <0.6 - , uniplate >=1.6.12 && <1.7 - , unsafe >=0.0 && <0.1 - , yaml >=0.8.18 && <0.12 + { base ^>= 4.15.0 + , aeson ^>= 2.0.1 + , butcher ^>= 1.3.3 + , bytestring ^>= 0.10.12 + , cmdargs ^>= 0.10.21 + , containers ^>= 0.6.4 + , czipwith ^>= 1.0.1 + , data-tree-print ^>= 0.1.0 + , deepseq ^>= 1.4.5 + , directory ^>= 1.3.6 + , extra ^>= 1.7.10 + , filepath ^>= 1.4.2 + , ghc ^>= 9.0.1 + , ghc-boot-th ^>= 9.0.1 + , ghc-exactprint ^>= 0.6.4 + , ghc-paths ^>= 0.1.0 + , monad-memo ^>= 0.5.3 + , mtl ^>= 2.2.2 + , multistate ^>= 0.8.0 + , pretty ^>= 1.1.3 + , random ^>= 1.2.1 + , safe ^>= 0.3.19 + , semigroups ^>= 0.19.2 + , strict ^>= 0.4.0 + , syb ^>= 0.7.2 + , text ^>= 1.2.5 + , transformers ^>= 0.5.6 + , uniplate ^>= 1.6.13 + , unsafe ^>= 0.0 + , yaml ^>= 0.11.7 } default-extensions: { CPP -- 2.30.2 From 116930ac2b6f815964fa04b609f3ce410a24d1d6 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 30 Oct 2021 16:20:13 +0000 Subject: [PATCH 397/478] Get everything building with (only) GHC 9.0 --- .vscode/extensions.json | 5 + src/Language/Haskell/Brittany/Internal.hs | 47 ++++------ .../Haskell/Brittany/Internal/Config/Types.hs | 14 +-- .../Internal/Config/Types/Instances.hs | 22 ++--- .../Brittany/Internal/ExactPrintUtils.hs | 50 ++++------ .../Brittany/Internal/LayouterBasics.hs | 14 +-- .../Brittany/Internal/Layouters/DataDecl.hs | 32 +++---- .../Brittany/Internal/Layouters/Decl.hs | 58 +++--------- .../Brittany/Internal/Layouters/Expr.hs | 91 ++----------------- .../Brittany/Internal/Layouters/Expr.hs-boot | 6 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 13 +-- .../Brittany/Internal/Layouters/Import.hs | 25 ++--- .../Brittany/Internal/Layouters/Module.hs | 19 ++-- .../Brittany/Internal/Layouters/Pattern.hs | 42 +++------ .../Brittany/Internal/Layouters/Stmt.hs | 14 +-- .../Brittany/Internal/Layouters/Stmt.hs-boot | 10 +- .../Brittany/Internal/Layouters/Type.hs | 40 +++----- .../Haskell/Brittany/Internal/Prelude.hs | 18 +--- .../Haskell/Brittany/Internal/Utils.hs | 20 +--- src/Language/Haskell/Brittany/Main.hs | 4 +- 20 files changed, 162 insertions(+), 382 deletions(-) create mode 100644 .vscode/extensions.json diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 0000000..8c8df54 --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "haskell.haskell" + ] +} diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 8489136..8c22c8d 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -53,21 +53,17 @@ import Language.Haskell.Brittany.Internal.Transformations.Indent import qualified GHC as GHC hiding ( parseModule ) -import ApiAnnotation ( AnnKeywordId(..) ) +import GHC.Parser.Annotation ( AnnKeywordId(..) ) import GHC ( Located , runGhc , GenLocated(L) , moduleNameString ) -import RdrName ( RdrName(..) ) -import SrcLoc ( SrcSpan ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Types.Name.Reader ( RdrName(..) ) +import GHC.Types.SrcLoc ( SrcSpan ) import GHC.Hs -import Bag -#else -import HsSyn -#endif -import qualified DynFlags as GHC +import GHC.Data.Bag +import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as GHC import Data.Char ( isSpace ) @@ -226,7 +222,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap -getTopLevelDeclNameMap (L _ (HsModule _name _exports _ decls _ _)) = +getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList [ (ExactPrint.mkAnnKey decl, name) | decl <- decls @@ -385,11 +381,7 @@ parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) -#else - Left (_ , s ) -> return $ Left $ "parsing error: " ++ s -#endif Right (anns, parsedModule) -> runExceptT $ do (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of @@ -460,8 +452,8 @@ toLocal conf anns m = do MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) pure x -ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM () -ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do +ppModule :: GenLocated SrcSpan HsModule -> PPM () +ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do let declAnnKey = ExactPrint.mkAnnKey decl @@ -505,10 +497,10 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr - (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> + (ExactPrint.G _, (ExactPrint.DP (eofZ, eofX))) -> let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of ExactPrint.AnnComment cm - | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm + | span <- ExactPrint.commentIdentifier cm -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span ) @@ -520,16 +512,16 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) - ValD _ (FunBind _ (L _ n) _ _ _) -> [Text.unpack $ rdrNameToText n] + ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] _ -> [] -- Prints the information associated with the module annotation -- This includes the imports ppPreamble - :: GenLocated SrcSpan (HsModule GhcPs) + :: GenLocated SrcSpan HsModule -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do +ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) @@ -550,15 +542,10 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do modAnnsDp = ExactPrint.annsDP mAnn isWhere (ExactPrint.G AnnWhere) = True isWhere _ = False - isEof (ExactPrint.G AnnEofPos) = True - isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post') = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + (pre, post') = case whereInd of + Nothing -> ([], modAnnsDp) + Just i -> List.splitAt (i + 1) modAnnsDp mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns @@ -585,7 +572,7 @@ _sigHead = \case _bindHead :: HsBind GhcPs -> String _bindHead = \case - FunBind _ fId _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) + FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" _ -> "unknown bind" diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index c5d8eb0..46b2ba1 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -340,16 +340,16 @@ data ExactPrintFallbackMode -- A PROGRAM BY TRANSFORMING IT. deriving (Show, Generic, Data) -instance CFunctor CDebugConfig -instance CFunctor CLayoutConfig -instance CFunctor CErrorHandlingConfig -instance CFunctor CForwardOptions -instance CFunctor CPreProcessorConfig -instance CFunctor CConfig - deriveCZipWith ''CDebugConfig deriveCZipWith ''CLayoutConfig deriveCZipWith ''CErrorHandlingConfig deriveCZipWith ''CForwardOptions deriveCZipWith ''CPreProcessorConfig deriveCZipWith ''CConfig + +instance CFunctor CDebugConfig +instance CFunctor CLayoutConfig +instance CFunctor CErrorHandlingConfig +instance CFunctor CForwardOptions +instance CFunctor CPreProcessorConfig +instance CFunctor CConfig diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 74dfe0e..7bf38f4 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -21,6 +21,7 @@ where #include "prelude.inc" import Data.Yaml +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson import Language.Haskell.Brittany.Internal.Config.Types @@ -113,18 +114,17 @@ makeToJSONMaybe(CConfig) -- config file content. instance FromJSON (CConfig Maybe) where parseJSON (Object v) = Config - <$> v .:? Text.pack "conf_version" - <*> v .:?= Text.pack "conf_debug" - <*> v .:?= Text.pack "conf_layout" - <*> v .:?= Text.pack "conf_errorHandling" - <*> v .:?= Text.pack "conf_forward" - <*> v .:?= Text.pack "conf_preprocessor" - <*> v .:? Text.pack "conf_roundtrip_exactprint_only" - <*> v .:? Text.pack "conf_disable_formatting" - <*> v .:? Text.pack "conf_obfuscate" + <$> v .:? Key.fromString "conf_version" + <*> v .:?= Key.fromString "conf_debug" + <*> v .:?= Key.fromString "conf_layout" + <*> v .:?= Key.fromString "conf_errorHandling" + <*> v .:?= Key.fromString "conf_forward" + <*> v .:?= Key.fromString "conf_preprocessor" + <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" + <*> v .:? Key.fromString "conf_disable_formatting" + <*> v .:? Key.fromString "conf_obfuscate" parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. -(.:?=) :: FromJSON a => Object -> Text -> Parser a +(.:?=) :: FromJSON a => Object -> Key.Key -> 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 index 9992dfd..2f9aba6 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -20,27 +20,22 @@ import Language.Haskell.Brittany.Internal.Utils import Data.Data import Data.HList.HList -import DynFlags ( getDynFlags ) +import GHC.Driver.Session ( getDynFlags ) import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified DynFlags as GHC +import qualified GHC.Driver.Session as GHC import qualified GHC as GHC hiding (parseModule) -import qualified Parser as GHC -import qualified SrcLoc as GHC -import qualified FastString as GHC -import qualified GHC as GHC hiding (parseModule) -import qualified Lexer as GHC -import qualified StringBuffer as GHC -import qualified Outputable as GHC -import qualified CmdLineParser as GHC +import qualified GHC.Parser as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Utils.Outputable as GHC +import qualified GHC.Driver.CmdLine as GHC -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -import Bag -#else -import HsSyn -#endif +import GHC.Data.Bag -import SrcLoc ( SrcSpan, Located ) +import GHC.Types.SrcLoc ( SrcSpan, Located ) import qualified Language.Haskell.GHC.ExactPrint as ExactPrint @@ -96,11 +91,7 @@ parseModuleWithCpp cpp opts args fp dynCheck = ++ show (warnings <&> warnExtractorCompat) x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) -#else - either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err) -#endif (\(a, m) -> pure (a, m, x)) $ ExactPrint.postParseTransform res opts @@ -133,11 +124,7 @@ parseModuleFromString args fp dynCheck str = dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) -#else - Left (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err -#endif Right (a , m ) -> pure (a, m, dynCheckRes) @@ -153,7 +140,7 @@ commentAnnFixTransformGlob ast = do annsMap = Map.fromListWith (flip const) [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span, annKey) <- Foldable.toList nodes + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes ] nodes `forM_` (snd .> processComs annsMap) where @@ -168,9 +155,8 @@ commentAnnFixTransformGlob ast = do :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> ExactPrint.TransformT Identity Bool processCom comPair@(com, _) = - case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of - GHC.UnhelpfulLoc{} -> return True -- retain comment at current node. - GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of + case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of + comLoc -> case Map.lookupLE comLoc annsMap of Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> move $> False @@ -179,8 +165,8 @@ commentAnnFixTransformGlob ast = do where ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.srcSpanStart annKeyLoc1 - loc2 = GHC.srcSpanStart annKeyLoc2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 move = ExactPrint.modifyAnnsT $ \anns -> let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns @@ -271,12 +257,12 @@ moveTrailingComments astFrom astTo = do -- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- implementation would have. extractToplevelAnns - :: Located (HsModule GhcPs) + :: Located HsModule -> ExactPrint.Anns -> Map ExactPrint.AnnKey ExactPrint.Anns extractToplevelAnns lmod anns = output where - (L _ (HsModule _ _ _ ldecls _ _)) = lmod + (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey declMap1 = Map.unions $ ldecls <&> \ldecl -> Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 770cbdd..a93996c 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -99,13 +99,13 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.ExactPrintUtils -import RdrName ( RdrName(..) ) +import GHC.Types.Name.Reader ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) -import qualified SrcLoc as GHC -import OccName ( occNameString ) -import Name ( getOccString ) -import Module ( moduleName ) -import ApiAnnotation ( AnnKeywordId(..) ) +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name ( getOccString ) +import GHC ( moduleName ) +import GHC.Parser.Annotation ( AnnKeywordId(..) ) import Data.Data import Data.Generics.Schemes @@ -299,7 +299,7 @@ filterAnns ast = -- b) after (in source code order) the node. hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow ast@(L l _) = - List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) + List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) <$> astConnectedComments ast hasCommentsBetween diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 22f11d4..999f6fb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -16,16 +16,12 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import RdrName ( RdrName(..) ) +import GHC.Types.Name.Reader ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import qualified GHC -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name -import BasicTypes +import GHC.Types.Name +import GHC.Types.Basic import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import Language.Haskell.Brittany.Internal.Layouters.Type @@ -34,7 +30,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Utils -import Bag ( mapBagM ) +import GHC.Data.Bag ( mapBagM ) @@ -242,11 +238,11 @@ createContextDoc (t1 : tR) = do ] ] -createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered +createBndrDoc :: [LHsTyVarBndr tag GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do tyVarDocs <- bs `forM` \case - (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar _ext lrdrName kind)) -> do + (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar _ _ext lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) (L _ (XTyVarBndr ext)) -> absurdExt ext @@ -334,21 +330,21 @@ createDetailsDoc consNameStr details = case details of , docForceSingleline $ docSeq $ List.intersperse docSeparator - $ args <&> layoutType + $ fmap hsScaledThing args <&> layoutType ] leftIndented = docSetParSpacing . docAddBaseY BrIndentRegular . docPar (docLit consNameStr) . docLines - $ layoutType <$> args + $ layoutType <$> fmap hsScaledThing args multiAppended = docSeq [ docLit consNameStr , docSeparator - , docSetBaseY $ docLines $ layoutType <$> args + , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args ] multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar (docLit consNameStr) - (docLines $ layoutType <$> args) + (docLines $ layoutType <$> fmap hsScaledThing args) case indentPolicy of IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] @@ -424,11 +420,11 @@ createDetailsDoc consNameStr details = case details of ] ) InfixCon arg1 arg2 -> docSeq - [ layoutType arg1 + [ layoutType $ hsScaledThing arg1 , docSeparator , docLit consNameStr , docSeparator - , layoutType arg2 + , layoutType $ hsScaledThing arg2 ] where mkFieldDocs @@ -438,7 +434,7 @@ createDetailsDoc consNameStr details = case details of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (XConDeclField x) -> absurdExt x -createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc :: [LHsTyVarBndr tag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc [] = Nothing createForallDoc lhsTyVarBndrs = Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index f6f59a4..669e285 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -27,6 +27,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils @@ -35,17 +36,12 @@ import GHC ( runGhc , moduleNameString , AnnKeywordId(..) ) -import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) -import qualified FastString -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ +import GHC.Types.SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) +import qualified GHC.Data.FastString as FastString import GHC.Hs import GHC.Hs.Extension (NoExtField (..)) -#else -import HsSyn -import HsExtension (NoExt (..)) -#endif -import Name -import BasicTypes ( InlinePragma(..) +import GHC.Types.Name +import GHC.Types.Basic ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) @@ -59,7 +55,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import Bag ( mapBagM, bagToList, emptyBag ) +import GHC.Data.Bag ( mapBagM, bagToList, emptyBag ) import Data.Char (isUpper) @@ -145,7 +141,7 @@ specStringCompat ast = \case layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of BodyStmt _ body _ _ -> layoutExpr body - BindStmt _ lPat expr _ _ -> do + BindStmt _ lPat expr -> do patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docCols ColBindStmt @@ -164,7 +160,7 @@ layoutBind (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of - FunBind _ fId (MG _ lmatches@(L _ matches) _) _ [] -> do + FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do idStr <- lrdrNameToTextAnn fId binderDoc <- docLit $ Text.pack "=" funcPatDocs <- @@ -186,11 +182,7 @@ layoutBind lbind@(L _ bind) = case bind of clauseDocs mWhereArg hasComments -#if MIN_VERSION_ghc(8,8,0) PatSynBind _ (PSB _ patID lpat rpat dir) -> do -#else - PatSynBind _ (PSB _ patID lpat rpat dir) -> do -#endif fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir @@ -226,7 +218,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of let unordered = [ BagBind b | b <- Data.Foldable.toList bindlrs ] ++ [ BagSig s | s <- sigs ] - ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered + ordered = sortBy (comparing $ ExactPrint.rs . bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s @@ -734,7 +726,7 @@ layoutSynDecl :: Bool -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) -> Located (IdP GhcPs) - -> [LHsTyVarBndr GhcPs] + -> [LHsTyVarBndr () GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered layoutSynDecl isInfix wrapNodeRest name vars typ = do @@ -771,14 +763,14 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc -layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr +layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" - UserTyVar _ name -> do + UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] - KindedTyVar _ name kind -> do + KindedTyVar _ _ name kind -> do nameStr <- lrdrNameToTextAnn name docSeq $ [ docSeparator | needsSep ] @@ -804,16 +796,10 @@ layoutTyFamInstDecl -> ToBriDocM BriDocNumbered layoutTyFamInstDecl inClass outerNode tfid = do let -#if MIN_VERSION_ghc(8,8,0) FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode -#else - FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid - bndrsMay = Nothing - innerNode = outerNode -#endif docWrapNodePrior outerNode $ do nameStr <- lrdrNameToTextAnn name needsParens <- hasAnnKeyword outerNode AnnOpenP @@ -822,7 +808,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do then docLit $ Text.pack "type" else docSeq [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] - makeForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered + makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered makeForallDoc bndrs = do bndrDocs <- layoutTyVarBndrs bndrs docSeq @@ -845,7 +831,6 @@ layoutTyFamInstDecl inClass outerNode tfid = do layoutLhsAndType hasComments lhs "=" typeDoc -#if MIN_VERSION_ghc(8,8,0) layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats pats = pats <&> \case HsValArg tm -> layoutType tm @@ -854,10 +839,6 @@ layoutHsTyPats pats = pats <&> \case -- is a bit strange. Hopefully this does not ignore any important -- annotations. HsArgPar _l -> error "brittany internal error: HsArgPar{}" -#else -layoutHsTyPats :: [LHsType GhcPs] -> [ToBriDocM BriDocNumbered] -layoutHsTyPats pats = layoutType <$> pats -#endif -------------------------------------------------------------------------------- -- ClsInstDecl @@ -881,21 +862,12 @@ layoutClsInst lcid@(L _ cid) = docLines ] where layoutInstanceHead :: ToBriDocM BriDocNumbered -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ layoutInstanceHead = briDocByExactNoComment $ InstD NoExtField . ClsInstD NoExtField . removeChildren <$> lcid -#else - layoutInstanceHead = - briDocByExactNoComment - $ InstD NoExt - . ClsInstD NoExt - . removeChildren - <$> lcid -#endif removeChildren :: ClsInstDecl p -> ClsInstDecl p removeChildren c = c @@ -909,7 +881,7 @@ layoutClsInst lcid@(L _ cid) = docLines docSortedLines :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = - allocateNode . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l + allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index ae514f1..9d1023a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -19,14 +19,10 @@ import Language.Haskell.Brittany.Internal.Config.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name -import qualified FastString -import BasicTypes +import GHC.Types.Name +import qualified GHC.Data.FastString as FastString +import GHC.Types.Basic import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Layouters.Pattern @@ -46,9 +42,8 @@ layoutExpr lexpr@(L _ expr) = do docWrapNode lexpr $ case expr of HsVar _ vname -> do docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ var -> case var of - OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname - TrueExprHole oname -> docLit $ Text.pack $ occNameString oname + HsUnboundVar _ oname -> + docLit $ Text.pack $ occNameString oname HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr @@ -79,8 +74,8 @@ layoutExpr lexpr@(L _ expr) = do -- by wrapping it in docSeq below. We _could_ add alignments for -- stuff like lists-of-lambdas. Nothing terribly important..) let shouldPrefixSeparator = case p of - (ghcDL -> L _ LazyPat{}) -> isFirst - (ghcDL -> L _ BangPat{}) -> isFirst + L _ LazyPat{} -> isFirst + L _ BangPat{} -> isFirst _ -> False patDocSeq <- layoutPat p fixed <- case Seq.viewl patDocSeq of @@ -235,15 +230,9 @@ layoutExpr lexpr@(L _ expr) = do expDoc1 expDoc2 ] -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ HsAppType _ _ XHsWildCardBndrs{} -> error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType _ exp1 (HsWC _ ty1) -> do -#else - HsAppType XHsWildCardBndrs{} _ -> - error "brittany internal error: HsAppType XHsWildCardBndrs" - HsAppType (HsWC _ ty1) exp1 -> do -#endif t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 docAlt @@ -400,17 +389,10 @@ layoutExpr lexpr@(L _ expr) = do rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple _ args boxity -> do -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ let argExprs = args <&> \arg -> case arg of (L _ (Present _ e)) -> (arg, Just e); (L _ (Missing NoExtField)) -> (arg, Nothing) (L _ XTupArg{}) -> error "brittany internal error: XTupArg" -#else - let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e); - (L _ (Missing NoExt)) -> (arg, Nothing) - (L _ XTupArg{}) -> error "brittany internal error: XTupArg" -#endif argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM @@ -496,7 +478,7 @@ layoutExpr lexpr@(L _ expr) = do (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) ] - HsIf _ _ ifExpr thenExpr elseExpr -> do + HsIf _ ifExpr thenExpr elseExpr -> do ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr @@ -723,14 +705,14 @@ layoutExpr lexpr@(L _ expr) = do _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of - DoExpr -> do + DoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "do") (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - MDoExpr -> do + MDoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts docSetParSpacing $ docAddBaseY BrIndentRegular @@ -829,18 +811,10 @@ layoutExpr lexpr@(L _ expr) = do else Just <$> docSharedWrapper layoutExpr rFExpr return $ (lfield, lrdrNameToText lnameF, rFExpDoc) recordExpression False indentPolicy lexpr nameDoc rFs -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ HsRecFields [] (Just (L _ 0)) -> do -#else - HsRecFields [] (Just 0) -> do -#endif let t = lrdrNameToText lname docWrapNode lname $ docLit $ t <> Text.pack " { .. }" -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do -#else - HsRecFields fs@(_:_) (Just dotdoti) | dotdoti == length fs -> do -#endif let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc @@ -863,19 +837,11 @@ layoutExpr lexpr@(L _ expr) = do XAmbiguousFieldOcc{} -> error "brittany internal error: XAmbiguousFieldOcc" recordExpression False indentPolicy lexpr rExprDoc rFs -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.6 */ ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) -> error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" ExprWithTySig _ _ XHsWildCardBndrs{} -> error "brittany internal error: ExprWithTySig XHsWildCardBndrs" ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do -#else - ExprWithTySig (HsWC _ XHsImplicitBndrs{}) _ -> - error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" - ExprWithTySig XHsWildCardBndrs{} _ -> - error "brittany internal error: ExprWithTySig XHsWildCardBndrs" - ExprWithTySig (HsWC _ (HsIB _ typ1)) exp1 -> do -#endif expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 docSeq @@ -927,12 +893,6 @@ layoutExpr lexpr@(L _ expr) = do ] ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr - HsSCC{} -> do - -- TODO - briDocByExactInlineOnly "HsSCC{}" lexpr - HsCoreAnn{} -> do - -- TODO - briDocByExactInlineOnly "HsCoreAnn{}" lexpr HsBracket{} -> do -- TODO briDocByExactInlineOnly "HsBracket{}" lexpr @@ -959,43 +919,12 @@ layoutExpr lexpr@(L _ expr) = do HsStatic{} -> do -- TODO briDocByExactInlineOnly "HsStatic{}" lexpr -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -#else - HsArrApp{} -> do - -- TODO - briDocByExactInlineOnly "HsArrApp{}" lexpr - HsArrForm{} -> do - -- TODO - briDocByExactInlineOnly "HsArrForm{}" lexpr -#endif HsTick{} -> do -- TODO briDocByExactInlineOnly "HsTick{}" lexpr HsBinTick{} -> do -- TODO briDocByExactInlineOnly "HsBinTick{}" lexpr - HsTickPragma{} -> do - -- TODO - briDocByExactInlineOnly "HsTickPragma{}" lexpr -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ -#else - EWildPat{} -> do - docLit $ Text.pack "_" - EAsPat _ asName asExpr -> do - docSeq - [ docLit $ lrdrNameToText asName <> Text.pack "@" - , layoutExpr asExpr - ] - EViewPat{} -> do - -- TODO - briDocByExactInlineOnly "EViewPat{}" lexpr - ELazyPat{} -> do - -- TODO - briDocByExactInlineOnly "ELazyPat{}" lexpr -#endif - HsWrap{} -> do - -- TODO - briDocByExactInlineOnly "HsWrap{}" lexpr HsConLikeOut{} -> do -- TODO briDocByExactInlineOnly "HsWrap{}" lexpr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index e3be109..f32fc3a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -15,12 +15,8 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import GHC ( runGhc, GenLocated(L), moduleNameString ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name +import GHC.Types.Name diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 2a722d1..7916d4d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -20,17 +20,12 @@ import GHC ( unLoc , Located , ModuleName ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs import GHC.Hs.ImpExp -#else -import HsSyn -import HsImpExp -#endif -import Name -import FieldLabel -import qualified FastString -import BasicTypes +import GHC.Types.Name +import GHC.Types.FieldLabel +import qualified GHC.Data.FastString +import GHC.Types.Basic import Language.Haskell.Brittany.Internal.Utils diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index e23c11b..09af4de 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -12,15 +12,12 @@ import GHC ( unLoc , moduleNameString , Located ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name -import FieldLabel -import qualified FastString -import BasicTypes +import GHC.Types.Name +import GHC.Types.FieldLabel +import qualified GHC.Data.FastString +import GHC.Types.Basic +import GHC.Unit.Types (IsBootInterface(..)) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.Brittany.Internal.Utils @@ -50,14 +47,10 @@ layoutImport importD = case importD of hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ let qualifiedPart = if q /= NotQualified then length "qualified " else 0 -#else - let qualifiedPart = if q then length "qualified " else 0 -#endif safePart = if safe then length "safe " else 0 pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = if src then length "{-# SOURCE #-} " else 0 + srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } in length "import " + srcPart + safePart + qualifiedPart + pkgPart qLength = max minQLength qLengthReal -- Cost in columns of importColumn @@ -66,13 +59,9 @@ layoutImport importD = case importD of nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" - , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty + , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty -#else - , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty -#endif , maybe docEmpty (appSep . docLit) pkgNameT ] indentName = diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 7887489..a968a97 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -11,17 +11,12 @@ import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Config.Types import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs import GHC.Hs.ImpExp -#else -import HsSyn -import HsImpExp -#endif -import Name -import FieldLabel -import qualified FastString -import BasicTypes +import GHC.Types.Name +import GHC.Types.FieldLabel +import qualified GHC.Data.FastString +import GHC.Types.Basic import Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types @@ -34,16 +29,16 @@ import Language.Haskell.Brittany.Internal.Utils -layoutModule :: ToBriDoc HsModule +layoutModule :: ToBriDoc' HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> do + HsModule _ Nothing _ imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- sortedImports <- sortImports imports -- docLines $ [layoutImport y i | (y, i) <- sortedImports] - HsModule (Just n) les imports _ _ _ -> do + HsModule _ (Just n) les imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow -- sortedImports <- sortImports imports diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 037d693..1fa3800 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -21,13 +21,9 @@ import GHC ( Located , ol_val ) import qualified GHC -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name -import BasicTypes +import GHC.Types.Name +import GHC.Types.Basic import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import Language.Haskell.Brittany.Internal.Layouters.Type @@ -45,7 +41,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type -- We will use `case .. of` as the imagined prefix to the examples used in -- the different cases below. layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) -layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of +layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr VarPat _ n -> @@ -54,11 +50,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ ParPat _ inner -> do -#else - ParPat _ inner -> do -#endif -- (nestedpat) -> expr left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" @@ -78,7 +70,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of -- x1' <- docSeq [docLit $ Text.pack "(", return x1] -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] -- return $ (x1' Seq.<| middle) Seq.|> xN' - ConPatIn lname (PrefixCon args) -> do + ConPat _ lname (PrefixCon args) -> do -- Abc a b c -> expr nameDoc <- lrdrNameToTextAnn lname argDocs <- layoutPat `mapM` args @@ -91,18 +83,18 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of $ spacifyDocs $ fmap colsWrapPat argDocs return $ x1 Seq.<| xR - ConPatIn lname (InfixCon left right) -> do + ConPat _ lname (InfixCon left right) -> do -- a :< b -> expr nameDoc <- lrdrNameToTextAnn lname leftDoc <- appSep . colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right middle <- appSep $ docLit nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc - ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do + ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname @@ -126,22 +118,14 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of , docSeparator , docLit $ Text.pack "}" ] -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - ConPatIn lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -#else - ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do -#endif + ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname Seq.singleton <$> docSeq [ appSep $ docLit t , docLit $ Text.pack "{..}" ] -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ - ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do -#else - ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do -#endif + ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do -- Abc { a = locA, .. } let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do @@ -172,11 +156,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of AsPat _ asName asPat -> do -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") -#if MIN_VERSION_ghc(8,8,0) /* ghc-8.8 */ - SigPat _ pat1 (HsWC _ (HsIB _ ty1)) -> do -#else - SigPat (HsWC _ (HsIB _ ty1)) pat1 -> do -#endif + SigPat _ pat1 (HsPS _ ty1) -> do -- i :: Int -> expr patDocs <- layoutPat pat1 tyDoc <- docSharedWrapper layoutType ty1 @@ -214,7 +194,7 @@ layoutPat (ghcDL -> lpat@(L _ pat)) = docWrapNode lpat $ case pat of Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc - _ -> return <$> briDocByExactInlineOnly "some unknown pattern" (ghcDL lpat) + _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 5427d7a..9971979 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -17,14 +17,10 @@ import GHC ( runGhc , GenLocated(L) , moduleNameString ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name -import qualified FastString -import BasicTypes +import GHC.Types.Name +import qualified GHC.Data.FastString as FastString +import GHC.Types.Basic import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.Decl @@ -38,9 +34,9 @@ layoutStmt lstmt@(L _ stmt) = do indentAmount :: Int <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack docWrapNode lstmt $ case stmt of - LastStmt _ body False _ -> do + LastStmt _ body (Just False) _ -> do layoutExpr body - BindStmt _ lPat expr _ _ -> do + BindStmt _ lPat expr -> do patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docAlt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 1fab3c5..5fa795b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -13,14 +13,10 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import GHC ( runGhc, GenLocated(L), moduleNameString ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name -import qualified FastString -import BasicTypes +import GHC.Types.Name +import qualified GHC.Data.FastString +import GHC.Types.Basic diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 3437fcd..1804bc6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -25,15 +25,11 @@ import GHC ( runGhc , AnnKeywordId (..) ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs -#else -import HsSyn -#endif -import Name -import Outputable ( ftext, showSDocUnsafe ) -import BasicTypes -import qualified SrcLoc +import GHC.Types.Name +import GHC.Utils.Outputable ( ftext, showSDocUnsafe ) +import GHC.Types.Basic +import qualified GHC.Types.SrcLoc import DataTreePrint @@ -45,21 +41,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsTyVar _ promoted name -> do t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of -#if MIN_VERSION_ghc(8,8,0) IsPromoted -> docSeq -#else /* ghc-8.6 */ - Promoted -> docSeq -#endif [ docSeparator , docTick , docWrapNode name $ docLit t ] NotPromoted -> docWrapNode name $ docLit t -#if MIN_VERSION_ghc(8,10,1) - HsForAllTy _ _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do -#else - HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do -#endif + HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do + let bndrs = hsf_vis_bndrs hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType @@ -145,11 +134,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] -#if MIN_VERSION_ghc(8,10,1) - HsForAllTy _ _ bndrs typ2 -> do -#else - HsForAllTy _ bndrs typ2 -> do -#endif + HsForAllTy _ hsf typ2 -> do + let bndrs = hsf_vis_bndrs hsf typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs let maybeForceML = case typ2 of @@ -254,7 +240,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] - HsFunTy _ typ1 typ2 -> do + HsFunTy _ _ typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 let maybeForceML = case typ2 of @@ -624,7 +610,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of then docLit $ Text.pack "\x2605" -- Unicode star else docLit $ Text.pack "*" XHsType{} -> error "brittany internal error: XHsType" -#if MIN_VERSION_ghc(8,8,0) HsAppKindTy _ ty kind -> do t <- docSharedWrapper layoutType ty k <- docSharedWrapper layoutType kind @@ -639,14 +624,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of t (docSeq [docLit $ Text.pack "@", k ]) ] -#endif layoutTyVarBndrs - :: [LHsTyVarBndr GhcPs] + :: [LHsTyVarBndr () GhcPs] -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] layoutTyVarBndrs = mapM $ \case - (L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar _ lrdrName kind)) -> do + (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ _ lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index b33e339..ef8cb90 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -8,16 +8,9 @@ where -- rather project-specific stuff: --------------------------------- -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs.Extension as E ( GhcPs ) -#else -import HsExtension as E ( GhcPs ) -#endif /* ghc-8.10.1 */ -import RdrName as E ( RdrName ) -#if MIN_VERSION_ghc(8,8,0) -import qualified GHC ( dL, HasSrcSpan, SrcSpanLess ) -#endif +import GHC.Types.Name.Reader as E ( RdrName ) import qualified GHC ( Located ) @@ -402,12 +395,3 @@ import Data.Data as E ( toConstr todo :: a todo = error "todo" - - -#if MIN_VERSION_ghc(8,8,0) -ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a) -ghcDL = GHC.dL -#else /* ghc-8.6 */ -ghcDL :: GHC.Located a -> GHC.Located a -ghcDL x = x -#endif diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 5ee7ed2..0654c12 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -46,11 +46,11 @@ import Data.Generics.Aliases import qualified Text.PrettyPrint as PP import Text.PrettyPrint ( ($+$), (<+>) ) -import qualified Outputable as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified SrcLoc as GHC -import OccName ( occNameString ) +import qualified GHC.Utils.Outputable as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.Name.Occurrence as OccName ( occNameString ) import qualified Data.ByteString as B import DataTreePrint @@ -59,11 +59,7 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import qualified GHC.Hs.Extension as HsExtension -#else -import qualified HsExtension -#endif /* ghc-8.10.1 */ @@ -301,11 +297,5 @@ lines' s = case break (== '\n') s of (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r -#if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon -#else --- | A method to dismiss NoExt patterns for total matches -absurdExt :: HsExtension.NoExt -> a -absurdExt = error "cannot construct NoExt" -#endif diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs index c2f2254..a84d882 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ b/src/Language/Haskell/Brittany/Main.hs @@ -16,7 +16,7 @@ import qualified Data.Map as Map import qualified Data.Monoid import GHC ( GenLocated(L) ) -import Outputable ( Outputable(..) +import GHC.Utils.Outputable ( Outputable(..) , showSDocUnsafe ) @@ -46,7 +46,7 @@ import qualified System.Exit import qualified System.Directory as Directory import qualified System.FilePath.Posix as FilePath -import qualified DynFlags as GHC +import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as GHC import Paths_brittany -- 2.30.2 From 515595b432463a32e2afc549d890dbdce0cbe410 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 30 Oct 2021 16:28:34 +0000 Subject: [PATCH 398/478] Append final newline --- src-libinterfacetests/Main.hs | 6 +++--- src-literatetests/Main.hs | 6 +++--- src/Language/Haskell/Brittany/Internal.hs | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src-libinterfacetests/Main.hs b/src-libinterfacetests/Main.hs index 8334328..973755e 100644 --- a/src-libinterfacetests/Main.hs +++ b/src-libinterfacetests/Main.hs @@ -26,7 +26,7 @@ main = hspec $ do , " ]" ] output <- liftIO $ parsePrintModule staticDefaultConfig input - input `shouldSatisfy` \_ -> case output of - Right x | x == expected -> True - _ -> False + hush output `shouldBe` Just expected +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index ae469e3..458566b 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -188,10 +188,10 @@ roundTripEqual c t = `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text - deriving Eq + deriving (Eq, Show) -instance Show PPTextWrapper where - show (PPTextWrapper t) = "\n" ++ Text.unpack t +-- instance Show PPTextWrapper where +-- show (PPTextWrapper t) = "\n" ++ Text.unpack t -- brittany-next-binding --columns 160 -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 8c22c8d..a90ac27 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -313,7 +313,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do True -> not $ null errsWarns if hasErrors then throwE $ errsWarns - else pure $ TextL.toStrict outputTextL + else pure $ TextL.toStrict $ TextL.snoc outputTextL '\n' @@ -398,7 +398,7 @@ parsePrintModuleTests conf filename input = do else lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule if null errs - then pure $ TextL.toStrict $ ltext + then pure $ TextL.toStrict $ TextL.snoc ltext '\n' else let errStrs = errs <&> \case -- 2.30.2 From 0f035faf3c7b767f98d4ad9f6bd3884c6b025ab6 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Tue, 2 Nov 2021 02:16:49 +0000 Subject: [PATCH 399/478] Fix matching of `LastStmt` --- src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 9971979..14be015 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -34,7 +34,7 @@ layoutStmt lstmt@(L _ stmt) = do indentAmount :: Int <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack docWrapNode lstmt $ case stmt of - LastStmt _ body (Just False) _ -> do + LastStmt _ body Nothing _ -> do layoutExpr body BindStmt _ lPat expr -> do patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat -- 2.30.2 From 22361c4ecd3f576abdd4fcf06c8de40d044ebdbf Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Tue, 2 Nov 2021 02:17:05 +0000 Subject: [PATCH 400/478] Fix getting binders from `HsForAllTy` --- .../Haskell/Brittany/Internal/Layouters/Type.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 1804bc6..5af9b2d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -48,7 +48,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] NotPromoted -> docWrapNode name $ docLit t HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do - let bndrs = hsf_vis_bndrs hsf + let bndrs = getBinders hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType @@ -135,7 +135,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ) ] HsForAllTy _ hsf typ2 -> do - let bndrs = hsf_vis_bndrs hsf + let bndrs = getBinders hsf typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs let maybeForceML = case typ2 of @@ -647,3 +647,15 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case , docForceSingleline $ doc , docLit $ Text.pack ")" ] + +getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] +getBinders x = case x of + HsForAllVis _ b -> b + HsForAllInvis _ b -> fmap withoutSpecificity b + XHsForAllTelescope _ -> [] + +withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass +withoutSpecificity = fmap $ \ x -> case x of + UserTyVar a _ c -> UserTyVar a () c + KindedTyVar a _ c d -> KindedTyVar a () c d + XTyVarBndr a -> XTyVarBndr a -- 2.30.2 From bd860f9983a5f65805bb0ca328ca419b4184c260 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Tue, 2 Nov 2021 08:10:44 -0400 Subject: [PATCH 401/478] Fix type variable name --- src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 999f6fb..750d0b1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -238,7 +238,7 @@ createContextDoc (t1 : tR) = do ] ] -createBndrDoc :: [LHsTyVarBndr tag GhcPs] -> ToBriDocM BriDocNumbered +createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do tyVarDocs <- bs `forM` \case (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) @@ -434,7 +434,7 @@ createDetailsDoc consNameStr details = case details of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (XConDeclField x) -> absurdExt x -createForallDoc :: [LHsTyVarBndr tag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc [] = Nothing createForallDoc lhsTyVarBndrs = Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] -- 2.30.2 From bfdb28010afb46c294f6bf2bf94468d46a683d8a Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Thu, 4 Nov 2021 23:05:43 +0000 Subject: [PATCH 402/478] Restore custom `Show` instance for `PPTextWrapper` --- src-literatetests/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 458566b..ae469e3 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -188,10 +188,10 @@ roundTripEqual c t = `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text - deriving (Eq, Show) + deriving Eq --- instance Show PPTextWrapper where --- show (PPTextWrapper t) = "\n" ++ Text.unpack t +instance Show PPTextWrapper where + show (PPTextWrapper t) = "\n" ++ Text.unpack t -- brittany-next-binding --columns 160 -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } -- 2.30.2 From 42cf56b1061da92fddbb76085b37abd0f401e2fe Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Thu, 4 Nov 2021 23:14:13 +0000 Subject: [PATCH 403/478] Switch to Purple Yolk --- .vscode/extensions.json | 2 +- .vscode/settings.json | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) create mode 100644 .vscode/settings.json diff --git a/.vscode/extensions.json b/.vscode/extensions.json index 8c8df54..c51a4b2 100644 --- a/.vscode/extensions.json +++ b/.vscode/extensions.json @@ -1,5 +1,5 @@ { "recommendations": [ - "haskell.haskell" + "taylorfausak.purple-yolk" ] } diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..0050442 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,6 @@ +{ + "purple-yolk.brittany.command": "false", + "purple-yolk.ghci.command": "cabal repl --repl-options -ddump-json", + "purple-yolk.hlint.command": "false", + "purple-yolk.hlint.onSave": false +} -- 2.30.2 From 1ad34aedccc54bcff5af81d6bd811de0453986fe Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 14:50:31 +0000 Subject: [PATCH 404/478] Remove unused HLS --- .devcontainer/Dockerfile | 5 ----- 1 file changed, 5 deletions(-) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index 2328b4d..bccc565 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -28,8 +28,3 @@ ARG CABAL_VERSION=3.6.2.0 RUN \ ghcup install cabal "$CABAL_VERSION" --set && \ cabal --version - -ARG HLS_VERSION=1.4.0 -RUN \ - ghcup install hls "$HLS_VERSION" --set && \ - haskell-language-server-wrapper --version -- 2.30.2 From 8290109e7fe2c5209ee0e7f43c04b3a68f6d175b Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 15:19:38 +0000 Subject: [PATCH 405/478] Fix handling of EOF --- src/Language/Haskell/Brittany/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index a90ac27..5129f77 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -313,7 +313,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do True -> not $ null errsWarns if hasErrors then throwE $ errsWarns - else pure $ TextL.toStrict $ TextL.snoc outputTextL '\n' + else pure $ TextL.toStrict outputTextL @@ -398,7 +398,7 @@ parsePrintModuleTests conf filename input = do else lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule if null errs - then pure $ TextL.toStrict $ TextL.snoc ltext '\n' + then pure $ TextL.toStrict ltext else let errStrs = errs <&> \case @@ -497,7 +497,7 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr - (ExactPrint.G _, (ExactPrint.DP (eofZ, eofX))) -> + (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -- 2.30.2 From 85359163cc26be7e11073e74b0f832ec54729eb2 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 15:22:13 +0000 Subject: [PATCH 406/478] Add back EOF handling --- src/Language/Haskell/Brittany/Internal.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 5129f77..7aa6127 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -398,7 +398,7 @@ parsePrintModuleTests conf filename input = do else lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule if null errs - then pure $ TextL.toStrict ltext + then pure $ TextL.toStrict $ ltext else let errStrs = errs <&> \case @@ -542,10 +542,15 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _ _)) = do modAnnsDp = ExactPrint.annsDP mAnn isWhere (ExactPrint.G AnnWhere) = True isWhere _ = False + isEof (ExactPrint.AnnEofPos) = True + isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp - (pre, post') = case whereInd of - Nothing -> ([], modAnnsDp) - Just i -> List.splitAt (i + 1) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns -- 2.30.2 From b517eef71e992eccfbe061746e8197ccc1fb4b83 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 16:46:24 +0000 Subject: [PATCH 407/478] Fix handling of type families --- src-literatetests/10-tests.blt | 91 +++++++++++++++++++++++ src/Language/Haskell/Brittany/Internal.hs | 11 ++- 2 files changed, 100 insertions(+), 2 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 806dd47..aa3c7cb 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1551,6 +1551,97 @@ instance Foo Int where { unBarInt :: Int } +############################################################################### +############################################################################### +############################################################################### +#group gh-357 +############################################################################### +############################################################################### +############################################################################### + +#test type-instance-without-comment + +{-# language TypeFamilies #-} +type family F a +type instance F Int = IO Int + +#test type-instance-with-comment + +{-# language TypeFamilies #-} +type family F a +type instance F Int = IO Int -- x + +#test newtype-instance-without-comment + +{-# language TypeFamilies #-} +data family F a +newtype instance F Int = N Int + +#test newtype-instance-with-comment + +{-# language TypeFamilies #-} +data family F a +newtype instance F Int = N Int -- x + +#test data-instance-without-comment + +{-# language TypeFamilies #-} +data family F a +data instance F Int = D Int + +#test data-instance-with-comment + +{-# language TypeFamilies #-} +data family F a +data instance F Int = D Int -- x + +#test instance-type-without-comment + +{-# language TypeFamilies #-} +class C a where + type family F a +instance C Int where + type F Int = IO Int + +#test instance-type-with-comment + +{-# language TypeFamilies #-} +class C a where + type family F a +instance C Int where + type F Int = IO Int -- x + +#test instance-newtype-without-comment + +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + newtype F Int = N Int + +#test instance-newtype-with-comment + +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + newtype F Int = N Int -- x + +#test instance-data-without-comment + +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + data F Int = D Int + +#test instance-data-with-comment + +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + data F Int = D Int -- x ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 7aa6127..c084c83 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -397,7 +397,7 @@ parsePrintModuleTests conf filename input = do then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule - if null errs + if null $ filter (not . isErrorUnusedComment) errs then pure $ TextL.toStrict $ ltext else let @@ -410,6 +410,10 @@ parsePrintModuleTests conf filename input = do ErrorOutputCheck -> "Output is not syntactically valid." in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs +isErrorUnusedComment :: BrittanyError -> Bool +isErrorUnusedComment x = case x of + ErrorUnusedComment _ -> True + _ -> False -- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally @@ -454,6 +458,7 @@ toLocal conf anns m = do ppModule :: GenLocated SrcSpan HsModule -> PPM () ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do + let annKey = ExactPrint.mkAnnKey lmod post <- ppPreamble lmod decls `forM_` \decl -> do let declAnnKey = ExactPrint.mkAnnKey decl @@ -463,7 +468,9 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do let mBindingConfs = declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf filteredAnns <- mAsk - <&> \annMap -> Map.findWithDefault Map.empty declAnnKey annMap + <&> \annMap -> + Map.union (Map.findWithDefault Map.empty annKey annMap) $ + Map.findWithDefault Map.empty declAnnKey annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations -- 2.30.2 From eccd2debb0de328dd7b9dd074a634b27c41f52de Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 16:55:46 +0000 Subject: [PATCH 408/478] Replace `Option` with `Maybe` --- src/Language/Haskell/Brittany/Internal.hs | 2 +- .../Haskell/Brittany/Internal/Config.hs | 17 +++---- .../Haskell/Brittany/Internal/Config/Types.hs | 50 +++++++++---------- .../Internal/Config/Types/Instances.hs | 22 -------- .../Haskell/Brittany/Internal/Prelude.hs | 1 - .../Haskell/Brittany/Internal/Types.hs | 4 +- .../Haskell/Brittany/Internal/Utils.hs | 4 +- 7 files changed, 38 insertions(+), 62 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index c084c83..e1a111e 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -79,7 +79,7 @@ data InlineConfigTarget extractCommentConfigs :: ExactPrint.Anns -> TopLevelDeclNameMap - -> Either (String, String) (CConfig Option, PerItemConfig) + -> Either (String, String) (CConfig Maybe, PerItemConfig) extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do let commentLiness = diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 520be3f..b6ead91 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -118,7 +118,7 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions } -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } -cmdlineConfigParser :: CmdParser Identity out (CConfig Option) +cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") @@ -196,10 +196,10 @@ cmdlineConfigParser = do , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where - falseToNothing = Option . Bool.bool Nothing (Just True) - wrapLast :: Option a -> Option (Semigroup.Last a) + falseToNothing = Bool.bool Nothing (Just True) + wrapLast :: Maybe a -> Maybe (Semigroup.Last a) wrapLast = fmap Semigroup.Last - optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a) + optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Maybe (f a) optionConcat = mconcat . fmap (pure . pure) -- configParser :: Parser Config @@ -230,7 +230,7 @@ cmdlineConfigParser = do -- If the second parameter is True and the file does not exist, writes the -- staticDefaultConfig to the file. readConfig - :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Option)) + :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe)) readConfig path = do -- TODO: probably should catch IOErrors and then omit the existence check. exists <- liftIO $ System.Directory.doesFileExist path @@ -278,7 +278,7 @@ findLocalConfigPath dir = do -- | Reads specified configs. readConfigs - :: CConfig Option -- ^ Explicit options, take highest priority + :: CConfig Maybe -- ^ Explicit options, take highest priority -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do @@ -290,7 +290,7 @@ readConfigs cmdlineConfig configPaths = do -- | Reads provided configs -- but also applies the user default configuration (with lowest priority) readConfigsWithUserConfig - :: CConfig Option -- ^ Explicit options, take highest priority + :: CConfig Maybe -- ^ Explicit options, take highest priority -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first -> MaybeT IO Config readConfigsWithUserConfig cmdlineConfig configPaths = do @@ -300,10 +300,9 @@ readConfigsWithUserConfig cmdlineConfig configPaths = do writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () writeDefaultConfig path = liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) + (Just . runIdentity) staticDefaultConfig showConfigYaml :: Config -> String showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap (\(Identity x) -> Just x) - diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 46b2ba1..18fb92b 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -23,7 +23,7 @@ import Data.Data ( Data ) import Data.Coerce ( Coercible, coerce ) import Data.Semigroup.Generic -import Data.Semigroup ( Last, Option ) +import Data.Semigroup ( Last ) import Data.CZipWith @@ -215,12 +215,12 @@ deriving instance Show (CForwardOptions Identity) deriving instance Show (CPreProcessorConfig Identity) deriving instance Show (CConfig Identity) -deriving instance Show (CDebugConfig Option) -deriving instance Show (CLayoutConfig Option) -deriving instance Show (CErrorHandlingConfig Option) -deriving instance Show (CForwardOptions Option) -deriving instance Show (CPreProcessorConfig Option) -deriving instance Show (CConfig Option) +deriving instance Show (CDebugConfig Maybe) +deriving instance Show (CLayoutConfig Maybe) +deriving instance Show (CErrorHandlingConfig Maybe) +deriving instance Show (CForwardOptions Maybe) +deriving instance Show (CPreProcessorConfig Maybe) +deriving instance Show (CConfig Maybe) deriving instance Data (CDebugConfig Identity) deriving instance Data (CLayoutConfig Identity) @@ -229,24 +229,24 @@ deriving instance Data (CForwardOptions Identity) deriving instance Data (CPreProcessorConfig Identity) deriving instance Data (CConfig Identity) -deriving instance Data (CDebugConfig Option) -deriving instance Data (CLayoutConfig Option) -deriving instance Data (CErrorHandlingConfig Option) -deriving instance Data (CForwardOptions Option) -deriving instance Data (CPreProcessorConfig Option) -deriving instance Data (CConfig Option) +deriving instance Data (CDebugConfig Maybe) +deriving instance Data (CLayoutConfig Maybe) +deriving instance Data (CErrorHandlingConfig Maybe) +deriving instance Data (CForwardOptions Maybe) +deriving instance Data (CPreProcessorConfig Maybe) +deriving instance Data (CConfig Maybe) -instance Semigroup.Semigroup (CDebugConfig Option) where +instance Semigroup.Semigroup (CDebugConfig Maybe) where (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Option) where +instance Semigroup.Semigroup (CLayoutConfig Maybe) where (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Option) where +instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Option) where +instance Semigroup.Semigroup (CForwardOptions Maybe) where (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Option) where +instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where (<>) = gmappend -instance Semigroup.Semigroup (CConfig Option) where +instance Semigroup.Semigroup (CConfig Maybe) where (<>) = gmappend instance Semigroup.Semigroup (CDebugConfig Identity) where @@ -262,22 +262,22 @@ instance Semigroup.Semigroup (CPreProcessorConfig Identity) where instance Semigroup.Semigroup (CConfig Identity) where (<>) = gmappend -instance Monoid (CDebugConfig Option) where +instance Monoid (CDebugConfig Maybe) where mempty = gmempty mappend = gmappend -instance Monoid (CLayoutConfig Option) where +instance Monoid (CLayoutConfig Maybe) where mempty = gmempty mappend = gmappend -instance Monoid (CErrorHandlingConfig Option) where +instance Monoid (CErrorHandlingConfig Maybe) where mempty = gmempty mappend = gmappend -instance Monoid (CForwardOptions Option) where +instance Monoid (CForwardOptions Maybe) where mempty = gmempty mappend = gmappend -instance Monoid (CPreProcessorConfig Option) where +instance Monoid (CPreProcessorConfig Maybe) where mempty = gmempty mappend = gmappend -instance Monoid (CConfig Option) where +instance Monoid (CConfig Maybe) where mempty = gmempty mappend = gmappend diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 7bf38f4..1ea7bab 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -51,27 +51,15 @@ aesonDecodeOptionsBrittany = Aeson.defaultOptions 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) @@ -85,28 +73,18 @@ 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 diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index ef8cb90..6c52450 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -32,7 +32,6 @@ 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(..) diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index f402e56..4979a4e 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -29,8 +29,8 @@ import Data.Generics.Uniplate.Direct as Uniplate data PerItemConfig = PerItemConfig - { _icd_perBinding :: Map String (CConfig Option) - , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option) + { _icd_perBinding :: Map String (CConfig Maybe) + , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) } deriving Data.Data.Data diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 0654c12..ea2b4ac 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -79,9 +79,9 @@ showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y -fromOptionIdentity :: Identity a -> Option a -> Identity a +fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity x y = - Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y + Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y -- maximum monoid over N+0 -- or more than N, because Num is allowed. -- 2.30.2 From acdc30c227742c9d7f1126cbe8c5f409f281557f Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 16:56:22 +0000 Subject: [PATCH 409/478] Comment out unused definitions --- .../Brittany/Internal/ExactPrintUtils.hs | 74 +++++++++---------- 1 file changed, 37 insertions(+), 37 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 2f9aba6..2100c4f 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -213,45 +213,45 @@ commentAnnFixTransformGlob ast = do -- moveTrailingComments lexpr (List.last fs) -- _ -> return () -commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () -commentAnnFixTransform modul = SYB.everything (>>) genF modul - where - genF :: Data.Data.Data a => a -> ExactPrint.Transform () - genF = (\_ -> return ()) `SYB.extQ` exprF - exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () - exprF lexpr@(L _ expr) = case expr of - RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> - moveTrailingComments lexpr (List.last fs) - RecordUpd _ _e fs@(_:_) -> - moveTrailingComments lexpr (List.last fs) - _ -> return () +-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransform modul = SYB.everything (>>) genF modul +-- where +-- genF :: Data.Data.Data a => a -> ExactPrint.Transform () +-- genF = (\_ -> return ()) `SYB.extQ` exprF +-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () +-- exprF lexpr@(L _ expr) = case expr of +-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +-- moveTrailingComments lexpr (List.last fs) +-- RecordUpd _ _e fs@(_:_) -> +-- moveTrailingComments lexpr (List.last fs) +-- _ -> return () -moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) - => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () -moveTrailingComments astFrom astTo = do - let - k1 = ExactPrint.mkAnnKey astFrom - k2 = ExactPrint.mkAnnKey astTo - moveComments ans = ans' - where - an1 = Data.Maybe.fromJust $ Map.lookup k1 ans - an2 = Data.Maybe.fromJust $ Map.lookup k2 ans - cs1f = ExactPrint.annFollowingComments an1 - cs2f = ExactPrint.annFollowingComments an2 - (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) - $ \case - (ExactPrint.AnnComment com, dp) -> Left (com, dp) - x -> Right x - an1' = an1 - { ExactPrint.annsDP = nonComments - , ExactPrint.annFollowingComments = [] - } - an2' = an2 - { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments - } - ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans +-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) +-- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () +-- moveTrailingComments astFrom astTo = do +-- let +-- k1 = ExactPrint.mkAnnKey astFrom +-- k2 = ExactPrint.mkAnnKey astTo +-- moveComments ans = ans' +-- where +-- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans +-- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans +-- cs1f = ExactPrint.annFollowingComments an1 +-- cs2f = ExactPrint.annFollowingComments an2 +-- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) +-- $ \case +-- (ExactPrint.AnnComment com, dp) -> Left (com, dp) +-- x -> Right x +-- an1' = an1 +-- { ExactPrint.annsDP = nonComments +-- , ExactPrint.annFollowingComments = [] +-- } +-- an2' = an2 +-- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments +-- } +-- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - ExactPrint.modifyAnnsT moveComments +-- 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 -- 2.30.2 From c361ba545d0f2800bb98907493454f83efcece99 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 16:57:02 +0000 Subject: [PATCH 410/478] Avoid relying on `StarIsType` --- src/Language/Haskell/Brittany/Internal/Types.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 4979a4e..d24907a 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -26,6 +26,8 @@ import Language.Haskell.Brittany.Internal.Config.Types import Data.Generics.Uniplate.Direct as Uniplate +import qualified Data.Kind as Kind + data PerItemConfig = PerItemConfig @@ -218,7 +220,7 @@ type ToBriDocM = MultiRWSS.MultiRWS '[[BrittanyError], Seq String] -- writer '[NodeAllocIndex] -- state -type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered type ToBriDocC sym c = Located sym -> ToBriDocM c -- 2.30.2 From 0c33d9a6fa168b1447d77e397904a5f5ce05bea4 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:01:11 +0000 Subject: [PATCH 411/478] Remove redundant pattern matches --- .../Brittany/Internal/Layouters/DataDecl.hs | 7 ------- .../Haskell/Brittany/Internal/Layouters/Decl.hs | 7 +------ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 17 +++-------------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 1 - .../Haskell/Brittany/Internal/Layouters/Type.hs | 1 - 5 files changed, 4 insertions(+), 29 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 750d0b1..b747293 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -40,7 +40,6 @@ layoutDataDecl -> LHsQTyVars GhcPs -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered -layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- newtype MyType a b = MyType .. HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of @@ -245,7 +244,6 @@ createBndrDoc bs = do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) - (L _ (XTyVarBndr ext)) -> absurdExt ext docSeq $ List.intersperse docSeparator $ tyVarDocs @@ -275,7 +273,6 @@ createDerivingPar derivs mainDoc = do <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of (L _ []) -> docSeq [] (L _ ts) -> @@ -295,7 +292,6 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of $ List.intersperse docCommaSep $ ts <&> \case HsIB _ t -> layoutType t - XHsImplicitBndrs x -> absurdExt x , whenMoreThan1Type ")" , rhsStrategy ] @@ -312,7 +308,6 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of , docSeparator , layoutType t ] - XHsImplicitBndrs ext -> absurdExt ext ) docDeriving :: ToBriDocM BriDocNumbered @@ -432,7 +427,6 @@ createDetailsDoc consNameStr details = case details of -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] mkFieldDocs = fmap $ \lField -> case lField of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t - L _ (XConDeclField x) -> absurdExt x createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc [] = Nothing @@ -451,7 +445,6 @@ createNamesAndTypeDoc lField names t = $ List.intersperse docCommaSep $ names <&> \case - L _ (XFieldOcc x) -> absurdExt x L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 669e285..d251dfb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -90,6 +90,7 @@ layoutSig lsig@(L _loc sig) = case sig of AlwaysActive -> "" ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" let conlikeStr = case conlike of FunLike -> "" ConLike -> "CONLIKE " @@ -190,7 +191,6 @@ layoutBind lbind@(L _ bind) = case bind of _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of - XIPBind{} -> unknownNodeError "XIPBind" lipbind IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" IPBind _ (Left (L _ (HsIPName name))) expr -> do ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name @@ -225,9 +225,6 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of return $ Just $ docs -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - XHsLocalBindsLR{} -> error "brittany internal error: XHsLocalBindsLR" - x@(HsIPBinds _ XHsIPBinds{}) -> - Just . (: []) <$> unknownNodeError "XHsIPBinds" (L noSrcSpan x) HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing @@ -241,7 +238,6 @@ layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) -layoutGrhs (L _ (XGRHS{})) = error "brittany internal error: XGRHS" layoutPatternBind :: Maybe Text @@ -766,7 +762,6 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of - XTyVarBndr{} -> error "brittany internal error: XTyVarBndr" UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 9d1023a..ac6e4ad 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -127,8 +127,6 @@ layoutExpr lexpr@(L _ expr) = do ] HsLam{} -> unknownNodeError "HsLam too complex" lexpr - HsLamCase _ XMatchGroup{} -> - error "brittany internal error: HsLamCase XMatchGroup" HsLamCase _ (MG _ (L _ []) _) -> do docSetParSpacing $ docAddBaseY BrIndentRegular $ (docLit $ Text.pack "\\case {}") @@ -230,8 +228,6 @@ layoutExpr lexpr@(L _ expr) = do expDoc1 expDoc2 ] - HsAppType _ _ XHsWildCardBndrs{} -> - error "brittany internal error: HsAppType XHsWildCardBndrs" HsAppType _ exp1 (HsWC _ ty1) -> do t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 @@ -392,7 +388,6 @@ layoutExpr lexpr@(L _ expr) = do let argExprs = args <&> \arg -> case arg of (L _ (Present _ e)) -> (arg, Just e); (L _ (Missing NoExtField)) -> (arg, Nothing) - (L _ XTupArg{}) -> error "brittany internal error: XTupArg" argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM @@ -437,8 +432,6 @@ layoutExpr lexpr@(L _ expr) = do lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] end = closeLit in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] - HsCase _ _ XMatchGroup{} -> - error "brittany internal error: HsCase XMatchGroup" HsCase _ cExp (MG _ (L _ []) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp docAlt @@ -834,13 +827,7 @@ layoutExpr lexpr@(L _ expr) = do return $ case ambName of Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - XAmbiguousFieldOcc{} -> - error "brittany internal error: XAmbiguousFieldOcc" recordExpression False indentPolicy lexpr rExprDoc rFs - ExprWithTySig _ _ (HsWC _ XHsImplicitBndrs{}) -> - error "brittany internal error: ExprWithTySig HsWC XHsImplicitBndrs" - ExprWithTySig _ _ XHsWildCardBndrs{} -> - error "brittany internal error: ExprWithTySig XHsWildCardBndrs" ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 @@ -931,7 +918,9 @@ layoutExpr lexpr@(L _ expr) = do ExplicitSum{} -> do -- TODO briDocByExactInlineOnly "ExplicitSum{}" lexpr - XExpr{} -> error "brittany internal error: XExpr" + HsPragE{} -> do + -- TODO + briDocByExactInlineOnly "HsPragE{}" lexpr recordExpression :: (Data.Data.Data lExpr, Data.Data.Data name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 7916d4d..45cd047 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -217,7 +217,6 @@ lieToText = \case L _ (IEGroup _ _ _ ) -> Text.pack "@IEGroup" L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" - L _ (XIE _ ) -> Text.pack "@XIE" where moduleNameToText :: Located ModuleName -> Text moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 5af9b2d..3d340ba 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -633,7 +633,6 @@ layoutTyVarBndrs = mapM $ \case (L _ (KindedTyVar _ _ lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) - (L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr" -- there is no specific reason this returns a list instead of a single -- BriDoc node. -- 2.30.2 From d89cf0ad303da37d0215b73cc2b1831bc2c13b28 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:03:42 +0000 Subject: [PATCH 412/478] Remove CPP --- .../Haskell/Brittany/Internal/BackendUtils.hs | 48 +------------------ .../Brittany/Internal/Transformations/Alt.hs | 46 ------------------ 2 files changed, 2 insertions(+), 92 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 1253f1a..201c7c5 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -1,11 +1,6 @@ -#define INSERTTRACES 0 - {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeApplications #-} -#if !INSERTTRACES -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif module Language.Haskell.Brittany.Internal.BackendUtils ( layoutWriteAppend @@ -58,13 +53,7 @@ traceLocal :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a) => a -> m () -#if INSERTTRACES -traceLocal x = do - mGet >>= tellDebugMessShow @LayoutState - tellDebugMessShow x -#else traceLocal _ = return () -#endif layoutWriteAppend @@ -79,21 +68,12 @@ layoutWriteAppend t = do state <- mGet case _lstate_curYOrAddNewline state of Right i -> do -#if INSERTTRACES - tellDebugMessShow (" inserted newlines: ", i) -#endif replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" Left{} -> do -#if INSERTTRACES - tellDebugMessShow (" inserted no newlines") -#endif return () let spaces = case _lstate_addSepSpace state of Just i -> i Nothing -> 0 -#if INSERTTRACES - tellDebugMessShow (" inserted spaces: ", spaces) -#endif mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') mTell $ Text.Builder.fromText $ t mModify $ \s -> s @@ -159,7 +139,7 @@ layoutWriteNewlineBlock = do -- mSet $ state -- { _lstate_addSepSpace = Just -- $ if isJust $ _lstate_addNewline state --- then i +-- then i -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } @@ -303,9 +283,6 @@ layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m ) => m () layoutRemoveIndentLevelLinger = do -#if INSERTTRACES - tellDebugMessShow ("layoutRemoveIndentLevelLinger") -#endif mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } @@ -318,9 +295,6 @@ layoutWithAddBaseCol => m () -> m () layoutWithAddBaseCol m = do -#if INSERTTRACES - tellDebugMessShow ("layoutWithAddBaseCol") -#endif amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack state <- mGet layoutBaseYPushInternal $ lstate_baseY state + amount @@ -336,9 +310,6 @@ layoutWithAddBaseColBlock => m () -> m () layoutWithAddBaseColBlock m = do -#if INSERTTRACES - tellDebugMessShow ("layoutWithAddBaseColBlock") -#endif amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack state <- mGet layoutBaseYPushInternal $ lstate_baseY state + amount @@ -390,9 +361,6 @@ layoutWithAddBaseColN -> m () -> m () layoutWithAddBaseColN amount m = do -#if INSERTTRACES - tellDebugMessShow ("layoutWithAddBaseColN", amount) -#endif state <- mGet layoutBaseYPushInternal $ lstate_baseY state + amount m @@ -444,9 +412,6 @@ layoutAddSepSpace :: (MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m) => m () layoutAddSepSpace = do -#if INSERTTRACES - tellDebugMessShow ("layoutAddSepSpace") -#endif state <- mGet mSet $ state { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } @@ -523,9 +488,6 @@ layoutWritePriorComments ast = do Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns } return mAnn -#if INSERTTRACES - tellDebugMessShow ("layoutWritePriorComments", ExactPrint.mkAnnKey ast, mAnn) -#endif case mAnn of Nothing -> return () Just priors -> do @@ -559,9 +521,6 @@ layoutWritePostComments ast = do anns } return mAnn -#if INSERTTRACES - tellDebugMessShow ("layoutWritePostComments", ExactPrint.mkAnnKey ast, mAnn) -#endif case mAnn of Nothing -> return () Just posts -> do @@ -584,9 +543,6 @@ layoutIndentRestorePostComment = do state <- mGet let mCommentCol = _lstate_commentCol state let eCurYAddNL = _lstate_curYOrAddNewline state -#if INSERTTRACES - tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) -#endif mModify $ \s -> s { _lstate_commentCol = Nothing , _lstate_commentNewlines = 0 } @@ -604,7 +560,7 @@ layoutIndentRestorePostComment = do -- layoutWritePriorCommentsRestore x = do -- layoutWritePriorComments x -- layoutIndentRestorePostComment --- +-- -- layoutWritePostCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, -- MonadMultiState LayoutState m diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 6a15eac..d186564 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -1,7 +1,3 @@ -#define INSERTTRACESALT 0 -#define INSERTTRACESALTVISIT 0 -#define INSERTTRACESGETSPACING 0 - {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} @@ -117,14 +113,6 @@ transformAlts = rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered rec bdX@(brDcId, brDc) = do -#if INSERTTRACESALTVISIT - do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: visiting: " ++ case brDc of - BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp) - BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp) - _ -> show (toConstr brDc, acp) -#endif let reWrap = (,) brDcId -- debugAcp :: AltCurPos <- mGet case brDc of @@ -206,20 +194,10 @@ transformAlts = -- TODO: use COMPLETE pragma instead? lineCheck _ = error "ghc exhaustive check is insufficient" lconf <- _conf_layout <$> mAsk -#if INSERTTRACESALT - tellDebugMess $ "considering options with " ++ show (length alts, acp) -#endif let options = -- trace ("considering options:" ++ show (length alts, acp)) $ (zip spacings alts <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) ( hasSpace1 lconf acp vs && lineCheck vs, bd)) -#if INSERTTRACESALT - zip spacings options `forM_` \(vs, (_, bd)) -> - tellDebugMess $ " " ++ "spacing=" ++ show vs - ++ ",hasSpace1=" ++ show (hasSpace1 lconf acp vs) - ++ ",lineCheck=" ++ show (lineCheck vs) - ++ " " ++ show (toConstr bd) -#endif id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) $ rec $ fromMaybe (-- trace ("choosing last") $ @@ -240,9 +218,6 @@ transformAlts = AltLineModeStateForceML{} -> p /= VerticalSpacingParNone AltLineModeStateContradiction -> False lconf <- _conf_layout <$> mAsk -#if INSERTTRACESALT - tellDebugMess $ "considering options with " ++ show (length alts, acp) -#endif let options = -- trace ("considering options:" ++ show (length alts, acp)) $ (zip spacings alts <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) @@ -250,14 +225,6 @@ transformAlts = && any lineCheck vs, bd)) let checkedOptions :: [Maybe (Int, BriDocNumbered)] = zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) -#if INSERTTRACESALT - zip spacings options `forM_` \(vs, (_, bd)) -> - tellDebugMess $ " " ++ "spacing=" ++ show vs - ++ ",hasSpace2=" ++ show (hasSpace2 lconf acp <$> vs) - ++ ",lineCheck=" ++ show (lineCheck <$> vs) - ++ " " ++ show (toConstr bd) - tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions) -#endif id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) $ rec $ fromMaybe (-- trace ("choosing last") $ @@ -510,9 +477,6 @@ getSpacing !bridoc = rec bridoc r <- rec bd tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r return r -#if INSERTTRACESGETSPACING - tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result -#endif return result maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs = foldl' @@ -867,16 +831,6 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc r <- rec bd tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) return r -#if INSERTTRACESGETSPACING - case brdc of - BDFAnnotationPrior{} -> return () - BDFAnnotationRest{} -> return () - _ -> mTell $ Seq.fromList ["getSpacings: visiting: " - ++ show (toConstr $ brdc) -- (briDocToDoc $ unwrapBriDocNumbered (0, brdc)) - , " -> " - ++ show (take 9 result) - ] -#endif return result maxVs :: [VerticalSpacing] -> VerticalSpacing maxVs = foldl' -- 2.30.2 From 56ccbc91a80c5f8c24dfda99c8da881541c6bbc9 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:04:46 +0000 Subject: [PATCH 413/478] Add `Paths_brittany` as an automatically generated module --- brittany.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/brittany.cabal b/brittany.cabal index 000c2bc..b389fe0 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -65,6 +65,7 @@ library { Language.Haskell.Brittany.Internal.Obfuscation Paths_brittany } + autogen-modules: Paths_brittany other-modules: { Language.Haskell.Brittany.Internal.LayouterBasics Language.Haskell.Brittany.Internal.Backend -- 2.30.2 From 19a092b862d8f73181363228e7d6a5ec2e7963ec Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:09:43 +0000 Subject: [PATCH 414/478] Remove CPP instances --- .../Internal/Config/Types/Instances.hs | 99 +++++++++++-------- 1 file changed, 58 insertions(+), 41 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 1ea7bab..b8ba9cf 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -36,56 +36,73 @@ aesonDecodeOptionsBrittany = Aeson.defaultOptions , 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 #-} +instance FromJSON (CDebugConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany -#define makeFromJSONMaybe(type)\ - instance FromJSON (type Maybe) where\ - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany;\ - {-# NOINLINE parseJSON #-} -#define makeToJSONMaybe(type)\ - instance ToJSON (type Maybe) where\ - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany;\ - {-# NOINLINE toJSON #-};\ - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany;\ - {-# NOINLINE toEncoding #-} +instance ToJSON (CDebugConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany +instance FromJSON IndentPolicy where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany -makeFromJSONMaybe(CDebugConfig) -makeToJSONMaybe(CDebugConfig) +instance ToJSON IndentPolicy where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany -makeFromJSON(IndentPolicy) -makeToJSON(IndentPolicy) -makeFromJSON(AltChooser) -makeToJSON(AltChooser) -makeFromJSON(ColumnAlignMode) -makeToJSON(ColumnAlignMode) -makeFromJSON(CPPMode) -makeToJSON(CPPMode) -makeFromJSON(ExactPrintFallbackMode) -makeToJSON(ExactPrintFallbackMode) +instance FromJSON AltChooser where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany -makeFromJSONMaybe(CLayoutConfig) -makeToJSONMaybe(CLayoutConfig) +instance ToJSON AltChooser where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany -makeFromJSONMaybe(CErrorHandlingConfig) -makeToJSONMaybe(CErrorHandlingConfig) +instance FromJSON ColumnAlignMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany -makeFromJSONMaybe(CForwardOptions) -makeToJSONMaybe(CForwardOptions) +instance ToJSON ColumnAlignMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany -makeFromJSONMaybe(CPreProcessorConfig) -makeToJSONMaybe(CPreProcessorConfig) +instance FromJSON CPPMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany -makeToJSONMaybe(CConfig) +instance ToJSON CPPMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON ExactPrintFallbackMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON ExactPrintFallbackMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON (CLayoutConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CLayoutConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CErrorHandlingConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CErrorHandlingConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CForwardOptions Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CForwardOptions Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CPreProcessorConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CPreProcessorConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance ToJSON (CConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany -- This custom instance ensures the "omitNothingFields" behaviour not only for -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- 2.30.2 From 1e7a94e72e330ba1f2837a8b32a57cb09e41a27a Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:12:55 +0000 Subject: [PATCH 415/478] Inline `prelude.inc` --- .hlint.yaml | 3 +- brittany.cabal | 6 - src-literatetests/Main.hs | 46 +++++- src-unittests/AsymptoticPerfTests.hs | 46 +++++- src-unittests/TestMain.hs | 46 +++++- src-unittests/TestUtils.hs | 46 +++++- src/Language/Haskell/Brittany.hs | 47 +++++- src/Language/Haskell/Brittany/Internal.hs | 46 +++++- .../Haskell/Brittany/Internal/Backend.hs | 47 +++++- .../Haskell/Brittany/Internal/BackendUtils.hs | 46 +++++- .../Haskell/Brittany/Internal/Config.hs | 46 +++++- .../Haskell/Brittany/Internal/Config/Types.hs | 46 +++++- .../Internal/Config/Types/Instances.hs | 46 +++++- .../Brittany/Internal/ExactPrintUtils.hs | 46 +++++- .../Brittany/Internal/LayouterBasics.hs | 46 +++++- .../Brittany/Internal/Layouters/DataDecl.hs | 46 +++++- .../Brittany/Internal/Layouters/Decl.hs | 46 +++++- .../Brittany/Internal/Layouters/Expr.hs | 46 +++++- .../Brittany/Internal/Layouters/Expr.hs-boot | 46 +++++- .../Haskell/Brittany/Internal/Layouters/IE.hs | 46 +++++- .../Brittany/Internal/Layouters/Import.hs | 46 +++++- .../Brittany/Internal/Layouters/Module.hs | 46 +++++- .../Brittany/Internal/Layouters/Pattern.hs | 46 +++++- .../Brittany/Internal/Layouters/Stmt.hs | 46 +++++- .../Brittany/Internal/Layouters/Stmt.hs-boot | 46 +++++- .../Brittany/Internal/Layouters/Type.hs | 46 +++++- .../Haskell/Brittany/Internal/Obfuscation.hs | 46 +++++- .../Brittany/Internal/Transformations/Alt.hs | 46 +++++- .../Internal/Transformations/Columns.hs | 46 +++++- .../Internal/Transformations/Floating.hs | 46 +++++- .../Internal/Transformations/Indent.hs | 46 +++++- .../Brittany/Internal/Transformations/Par.hs | 46 +++++- .../Haskell/Brittany/Internal/Types.hs | 46 +++++- .../Haskell/Brittany/Internal/Utils.hs | 46 +++++- src/Language/Haskell/Brittany/Main.hs | 46 +++++- srcinc/prelude.inc | 147 ------------------ 36 files changed, 1486 insertions(+), 190 deletions(-) delete mode 100644 srcinc/prelude.inc diff --git a/.hlint.yaml b/.hlint.yaml index 6fecf6a..1aaea27 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -8,8 +8,7 @@ # Specify additional command line arguments - arguments: - [ "--cpp-include=srcinc" - , "--language=GADTs" + [ "--language=GADTs" , "--language=LambdaCase" , "--language=MultiWayIf" , "--language=KindSignatures" diff --git a/brittany.cabal b/brittany.cabal index b389fe0..48f08ca 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -26,7 +26,6 @@ extra-doc-files: { } extra-source-files: { src-literatetests/*.blt - srcinc/prelude.inc } source-repository head { @@ -49,8 +48,6 @@ library { Haskell2010 hs-source-dirs: src - include-dirs: - srcinc exposed-modules: { Language.Haskell.Brittany Language.Haskell.Brittany.Main @@ -206,7 +203,6 @@ test-suite unittests other-modules: TestUtils AsymptoticPerfTests hs-source-dirs: src-unittests - include-dirs: srcinc default-extensions: { CPP @@ -278,7 +274,6 @@ test-suite littests main-is: Main.hs other-modules: hs-source-dirs: src-literatetests - include-dirs: srcinc default-extensions: { CPP @@ -320,7 +315,6 @@ test-suite libinterfacetests main-is: Main.hs other-modules: hs-source-dirs: src-libinterfacetests - include-dirs: srcinc default-extensions: { FlexibleContexts FlexibleInstances diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index ae469e3..bc860ce 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -8,7 +8,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Test.Hspec import Test.Hspec.Runner ( hspecWith diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs index f3f35ba..636ff89 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -7,7 +7,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Test.Hspec diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs index ca6dbb5..66eaed2 100644 --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -4,7 +4,51 @@ module Main where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Test.Hspec diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 052ade6..a8b8e2e 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -4,7 +4,51 @@ module TestUtils where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Test.Hspec diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 9d45dde..4eb99ea 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -21,10 +21,53 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config - diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e1a111e..9bdd6cf 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -15,7 +15,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } import qualified Language.Haskell.GHC.ExactPrint as ExactPrint diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 234d55e..a22da90 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -12,7 +12,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate @@ -716,4 +760,3 @@ processInfoIgnore = \case ColInfoStart -> error "should not happen (TM)" ColInfoNo doc -> layoutBriDocM doc ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) - diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 201c7c5..99eb46b 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -32,7 +32,51 @@ module Language.Haskell.Brittany.Internal.BackendUtils where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index b6ead91..904c272 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -20,7 +20,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 18fb92b..d596708 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -12,7 +12,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Data.Yaml import qualified Data.Aeson.Types as Aeson diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index b8ba9cf..d0838c0 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -18,7 +18,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Data.Yaml import qualified Data.Aeson.Key as Key diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 2100c4f..036f5d9 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -12,7 +12,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index a93996c..2c1a37d 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -80,7 +80,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import qualified Control.Monad.Writer.Strict as Writer diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index b747293..243dbf6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -10,7 +10,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index d251dfb..38843f6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -18,7 +18,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index ac6e4ad..1386816 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -10,7 +10,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index f32fc3a..8e77eda 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -9,7 +9,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 45cd047..89945cd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -6,7 +6,51 @@ module Language.Haskell.Brittany.Internal.Layouters.IE ) where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 09af4de..1eae5d6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -1,6 +1,50 @@ module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index a968a97..014b9fe 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -2,7 +2,51 @@ module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 1fa3800..bf5b8e0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -9,7 +9,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 14be015..30867aa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -7,7 +7,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 5fa795b..94f0d3c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -7,7 +7,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 3d340ba..aac5453 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -9,7 +9,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs index 5bdcfa8..7aa2ed6 100644 --- a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -5,7 +5,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Data.Char import System.Random diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index d186564..7e5677b 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -9,7 +9,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Data.HList.ContainsType diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index d652dda..f10853d 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -5,7 +5,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 4bb227b..992d3b0 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -5,7 +5,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index b3d7709..f1c43b2 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -5,7 +5,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs index e048584..f1b3973 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -5,7 +5,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index d24907a..f04d2a6 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -10,7 +10,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index ea2b4ac..43f9382 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -32,7 +32,51 @@ where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs index a84d882..354c2ce 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ b/src/Language/Haskell/Brittany/Main.hs @@ -4,7 +4,51 @@ module Language.Haskell.Brittany.Main (main) where -#include "prelude.inc" +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +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.Writer.Class as Writer.Class +import qualified Data.Bool as Bool +import qualified Data.ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteStringL +import qualified Data.Coerce +import qualified Data.Data +import qualified Data.Either +import qualified Data.Foldable +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.List.Extra +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO +import qualified GHC.OldList as List +import qualified Safe as Safe +import qualified System.Directory +import qualified System.IO +import qualified Text.PrettyPrint +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } import qualified Language.Haskell.GHC.ExactPrint as ExactPrint diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc deleted file mode 100644 index 81ca53a..0000000 --- a/srcinc/prelude.inc +++ /dev/null @@ -1,147 +0,0 @@ -import qualified Data.ByteString --- import qualified Data.ByteString.Builder --- import qualified Data.ByteString.Builder.Extra --- import qualified Data.ByteString.Builder.Prim -import qualified Data.ByteString.Char8 --- import qualified Data.ByteString.Lazy.Builder --- import qualified Data.ByteString.Lazy.Builder.ASCII --- import qualified Data.ByteString.Lazy.Builder.Extras --- import qualified Data.ByteString.Lazy.Char8 --- import qualified Data.ByteString.Lazy --- import qualified Data.ByteString.Short --- import qualified Data.ByteString.Unsafe - --- import qualified Data.Graph --- import qualified Data.IntMap --- import qualified Data.IntMap.Lazy --- import qualified Data.IntMap.Strict --- import qualified Data.IntSet --- import qualified Data.Map --- import qualified Data.Map.Lazy --- import qualified Data.Map.Strict --- import qualified Data.Sequence --- import qualified Data.Set --- import qualified Data.Tree - -import qualified System.Directory - --- import qualified Control.Concurrent.Extra --- import qualified Control.Exception.Extra --- import qualified Control.Monad.Extra --- import qualified Data.Either.Extra --- import qualified Data.IORef.Extra -import qualified Data.List.Extra --- import qualified Data.Tuple.Extra --- import qualified Data.Version.Extra --- import qualified Numeric.Extra --- import qualified System.Directory.Extra --- import qualified System.Environment.Extra --- import qualified System.IO.Extra --- import qualified System.Info.Extra --- import qualified System.Process.Extra --- import qualified System.Time.Extra - --- import qualified Control.Monad.Trans.MultiRWS.Lazy --- import qualified Control.Monad.Trans.MultiRWS.Strict --- import qualified Control.Monad.Trans.MultiReader --- import qualified Control.Monad.Trans.MultiReader.Class --- import qualified Control.Monad.Trans.MultiReader.Lazy --- import qualified Control.Monad.Trans.MultiReader.Strict --- import qualified Control.Monad.Trans.MultiState --- import qualified Control.Monad.Trans.MultiState.Class --- import qualified Control.Monad.Trans.MultiState.Lazy --- import qualified Control.Monad.Trans.MultiState.Strict --- import qualified Control.Monad.Trans.MultiWriter --- import qualified Control.Monad.Trans.MultiWriter.Class --- import qualified Control.Monad.Trans.MultiWriter.Lazy --- import qualified Control.Monad.Trans.MultiWriter.Strict - -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL - -import qualified Text.PrettyPrint - -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass - --- import qualified Text.PrettyPrint.HughesPJ --- import qualified Text.PrettyPrint.HughesPJClass - --- import qualified Data.Text --- import qualified Data.Text.Array --- import qualified Data.Text.Encoding --- import qualified Data.Text.Encoding.Error --- import qualified Data.Text.Foreign --- import qualified Data.Text.IO --- import qualified Data.Text.Lazy --- import qualified Data.Text.Lazy.Builder - --- import qualified Data.Bifunctor --- import qualified Data.Bits --- import qualified Data.Bool --- import qualified Data.Char -import qualified Data.Coerce --- import qualified Data.Complex -import qualified Data.Data --- import qualified Data.Dynamic -import qualified Data.Either --- import qualified Data.Eq --- import qualified Data.Fixed -import qualified Data.Foldable --- import qualified Data.Function --- import qualified Data.Functor --- import qualified Data.Functor.Identity --- import qualified Data.IORef --- import qualified Data.Int --- import qualified Data.Ix --- import qualified Data.List -import qualified Data.Maybe --- import qualified Data.Monoid --- import qualified Data.Ord --- import qualified Data.Proxy --- import qualified Debug.Trace --- import qualified Numeric --- import qualified Numeric.Natural -import qualified System.IO --- import qualified Unsafe.Coerce - -import qualified Data.Bool as Bool -import qualified Data.Foldable as Foldable -import qualified GHC.OldList as List - -import qualified Data.Semigroup as Semigroup - -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as ByteStringL - -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set - -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Writer.Class as Writer.Class - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO - -import qualified Control.Monad.Trans.State as State -import qualified Control.Monad.Trans.State.Lazy as StateL -import qualified Control.Monad.Trans.State.Strict as StateS -import qualified Control.Monad.Trans.Except as ExceptT - -import qualified Data.Strict.Maybe as Strict - -import qualified Safe as Safe - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -- 2.30.2 From 32da5defb54b81d87fa23e4f78a02dd72e2534a5 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:27:19 +0000 Subject: [PATCH 416/478] Remove unused imports --- brittany.cabal | 1 - src/Language/Haskell/Brittany.hs | 45 ---------------- src/Language/Haskell/Brittany/Internal.hs | 43 +--------------- .../Haskell/Brittany/Internal/Backend.hs | 44 ---------------- .../Haskell/Brittany/Internal/BackendUtils.hs | 39 +------------- .../Haskell/Brittany/Internal/Config.hs | 45 +--------------- .../Haskell/Brittany/Internal/Config/Types.hs | 46 +---------------- .../Internal/Config/Types/Instances.hs | 46 ----------------- .../Brittany/Internal/ExactPrintUtils.hs | 46 +---------------- .../Brittany/Internal/LayouterBasics.hs | 43 +--------------- .../Brittany/Internal/Layouters/DataDecl.hs | 51 +------------------ .../Brittany/Internal/Layouters/Decl.hs | 51 ++----------------- .../Brittany/Internal/Layouters/Expr.hs | 42 +-------------- .../Brittany/Internal/Layouters/Expr.hs-boot | 47 ----------------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 48 ----------------- .../Brittany/Internal/Layouters/Import.hs | 47 ----------------- .../Brittany/Internal/Layouters/Module.hs | 49 +----------------- .../Brittany/Internal/Layouters/Pattern.hs | 46 +---------------- .../Brittany/Internal/Layouters/Stmt.hs | 48 +---------------- .../Brittany/Internal/Layouters/Stmt.hs-boot | 49 ------------------ .../Brittany/Internal/Layouters/Type.hs | 51 +------------------ .../Haskell/Brittany/Internal/Obfuscation.hs | 39 -------------- .../Haskell/Brittany/Internal/Prelude.hs | 38 ++------------ .../Brittany/Internal/Transformations/Alt.hs | 38 -------------- .../Internal/Transformations/Columns.hs | 45 ---------------- .../Internal/Transformations/Floating.hs | 43 ---------------- .../Internal/Transformations/Indent.hs | 45 ---------------- .../Brittany/Internal/Transformations/Par.hs | 47 ----------------- .../Haskell/Brittany/Internal/Types.hs | 46 ++--------------- .../Haskell/Brittany/Internal/Utils.hs | 43 ---------------- src/Language/Haskell/Brittany/Main.hs | 42 --------------- 31 files changed, 24 insertions(+), 1329 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 48f08ca..0c447e9 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -85,7 +85,6 @@ library { } ghc-options: { -Wall - -fno-warn-unused-imports -fno-warn-redundant-constraints } build-depends: diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 4eb99ea..a4fc839 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -21,51 +21,6 @@ where -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Types diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 9bdd6cf..81c7733 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -17,60 +17,24 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import Data.Data import Control.Monad.Trans.Except import Data.HList.HList import qualified Data.Yaml -import qualified Data.ByteString.Char8 import Data.CZipWith import qualified UI.Butcher.Monadic as Butcher @@ -81,7 +45,6 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Module import Language.Haskell.Brittany.Internal.Utils @@ -98,12 +61,8 @@ import Language.Haskell.Brittany.Internal.Transformations.Indent import qualified GHC as GHC hiding ( parseModule ) import GHC.Parser.Annotation ( AnnKeywordId(..) ) -import GHC ( Located - , runGhc - , GenLocated(L) - , moduleNameString +import GHC ( GenLocated(L) ) -import GHC.Types.Name.Reader ( RdrName(..) ) import GHC.Types.SrcLoc ( SrcSpan ) import GHC.Hs import GHC.Data.Bag diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index a22da90..92c29fb 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -14,56 +14,19 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable import qualified Data.Foldable as Foldable import qualified Data.IntMap.Lazy as IntMapL import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) - -import GHC ( AnnKeywordId (..) ) import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.BackendUtils @@ -75,13 +38,6 @@ import Language.Haskell.Brittany.Internal.Types import qualified Data.Text.Lazy.Builder as Text.Builder -import Data.HList.ContainsType - -import Control.Monad.Extra ( whenM ) - -import qualified Control.Monad.Trans.Writer.Strict as WriterS - - type ColIndex = Int diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 99eb46b..93b7dc7 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -34,62 +34,25 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce import qualified Data.Data import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.GHC.ExactPrint.Types ( AnnKey , Annotation - , KeywordId ) import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.Utils -import GHC ( Located, GenLocated(L), moduleNameString ) +import GHC ( Located ) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 904c272..22d7163 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -22,68 +22,27 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class import qualified Data.Bool as Bool -import qualified Data.ByteString import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe import qualified System.Directory import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics import qualified Data.Yaml import Data.CZipWith import UI.Butcher.Monadic -import Data.Monoid ( (<>) ) import qualified System.Console.CmdArgs.Explicit as CmdArgs import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances +import Language.Haskell.Brittany.Internal.Config.Types.Instances () import Language.Haskell.Brittany.Internal.Utils -import Data.Coerce ( Coercible - , coerce +import Data.Coerce ( coerce ) import qualified Data.List.NonEmpty as NonEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index d596708..e758b2e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -13,53 +13,9 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe +import Language.Haskell.Brittany.Internal.PreludeUtils () import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -import Data.Yaml -import qualified Data.Aeson.Types as Aeson import GHC.Generics import Data.Data ( Data ) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index d0838c0..0ad985c 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -19,50 +19,6 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Data.Yaml import qualified Data.Aeson.Key as Key @@ -70,8 +26,6 @@ import qualified Data.Aeson.Types as Aeson import Language.Haskell.Brittany.Internal.Config.Types -import GHC.Generics - aesonDecodeOptionsBrittany :: Aeson.Options diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 036f5d9..c17e8b1 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -14,66 +14,24 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra import qualified Data.Map as Map import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils import Data.Data import Data.HList.HList -import GHC.Driver.Session ( getDynFlags ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) +import GHC ( GenLocated(L) ) import qualified GHC.Driver.Session as GHC import qualified GHC as GHC hiding (parseModule) -import qualified GHC.Parser as GHC import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Data.FastString as GHC -import qualified GHC.Parser.Lexer as GHC -import qualified GHC.Data.StringBuffer as GHC -import qualified GHC.Utils.Outputable as GHC import qualified GHC.Driver.CmdLine as GHC import GHC.Hs @@ -83,10 +41,8 @@ import GHC.Types.SrcLoc ( SrcSpan, Located ) import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Data.Generics as SYB diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 2c1a37d..296f3ba 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -82,49 +82,13 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import qualified Control.Monad.Writer.Strict as Writer @@ -134,7 +98,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation, KeywordId ) +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) import qualified Data.Text.Lazy.Builder as Text.Builder @@ -144,7 +108,7 @@ import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.ExactPrintUtils import GHC.Types.Name.Reader ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import GHC ( Located, GenLocated(L), moduleNameString ) import qualified GHC.Types.SrcLoc as GHC import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name ( getOccString ) @@ -152,14 +116,11 @@ import GHC ( moduleName ) import GHC.Parser.Annotation ( AnnKeywordId(..) ) import Data.Data -import Data.Generics.Schemes import qualified Data.Char as Char import DataTreePrint -import Data.HList.HList - processDefault diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 243dbf6..59a54bb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -12,69 +12,20 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import GHC.Types.Name.Reader ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import GHC ( Located, GenLocated(L) ) import qualified GHC import GHC.Hs -import GHC.Types.Name -import GHC.Types.Basic -import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import Language.Haskell.Brittany.Internal.Layouters.Type -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Utils - -import GHC.Data.Bag ( mapBagM ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 38843f6..47a9514 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -20,49 +20,12 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce import qualified Data.Data -import qualified Data.Either import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics @@ -70,21 +33,15 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Layouters.Type import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc - , GenLocated(L) - , moduleNameString +import GHC ( GenLocated(L) , AnnKeywordId(..) ) -import GHC.Types.SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) +import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc ) import qualified GHC.Data.FastString as FastString import GHC.Hs -import GHC.Hs.Extension (NoExtField (..)) -import GHC.Types.Name import GHC.Types.Basic ( InlinePragma(..) , Activation(..) , InlineSpec(..) @@ -93,14 +50,12 @@ import GHC.Types.Basic ( InlinePragma(..) ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) -import Language.Haskell.Brittany.Internal.Layouters.Type import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import GHC.Data.Bag ( mapBagM, bagToList, emptyBag ) -import Data.Char (isUpper) +import GHC.Data.Bag ( bagToList, emptyBag ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 1386816..f2b9674 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -12,57 +12,17 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - -import GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) ) +import GHC ( GenLocated(L), SrcSpan, AnnKeywordId(..), RdrName(..) ) import GHC.Hs import GHC.Types.Name import qualified GHC.Data.FastString as FastString diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 8e77eda..1c748f0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -10,57 +10,10 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC.Hs -import GHC.Types.Name diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 89945cd..b7b3bb3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -7,57 +7,14 @@ module Language.Haskell.Brittany.Internal.Layouters.IE where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types import GHC ( unLoc - , runGhc , GenLocated(L) , moduleNameString , AnnKeywordId(..) @@ -65,11 +22,6 @@ import GHC ( unLoc , ModuleName ) import GHC.Hs -import GHC.Hs.ImpExp -import GHC.Types.Name -import GHC.Types.FieldLabel -import qualified GHC.Data.FastString -import GHC.Types.Basic import Language.Haskell.Brittany.Internal.Utils diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 1eae5d6..128c13f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -2,49 +2,8 @@ module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics @@ -57,14 +16,8 @@ import GHC ( unLoc , Located ) import GHC.Hs -import GHC.Types.Name -import GHC.Types.FieldLabel -import qualified GHC.Data.FastString import GHC.Types.Basic import GHC.Unit.Types (IsBootInterface(..)) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - -import Language.Haskell.Brittany.Internal.Utils diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 014b9fe..48d789b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -4,49 +4,10 @@ module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics @@ -54,23 +15,15 @@ import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Config.Types -import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..)) import GHC.Hs -import GHC.Hs.ImpExp -import GHC.Types.Name -import GHC.Types.FieldLabel -import qualified GHC.Data.FastString -import GHC.Types.Basic import Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types ( DeltaPos(..) , deltaRow , commentContents ) -import Language.Haskell.Brittany.Internal.Utils - layoutModule :: ToBriDoc' HsModule diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index bf5b8e0..9bc39cf 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -11,62 +11,18 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import GHC ( Located - , runGhc - , GenLocated(L) - , moduleNameString +import GHC ( GenLocated(L) , ol_val ) -import qualified GHC import GHC.Hs -import GHC.Types.Name import GHC.Types.Basic import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 30867aa..2af1ada 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -9,62 +9,16 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types -import GHC ( runGhc - , GenLocated(L) - , moduleNameString +import GHC ( GenLocated(L) ) import GHC.Hs -import GHC.Types.Name -import qualified GHC.Data.FastString as FastString -import GHC.Types.Basic import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.Decl diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 94f0d3c..1b35a55 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -8,59 +8,10 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC.Hs -import GHC.Types.Name -import qualified GHC.Data.FastString -import GHC.Types.Basic diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index aac5453..4aead4e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -11,51 +11,9 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Utils @@ -63,19 +21,12 @@ import Language.Haskell.Brittany.Internal.Utils , FirstLastView(..) ) -import GHC ( runGhc - , GenLocated(L) - , moduleNameString +import GHC ( GenLocated(L) , AnnKeywordId (..) ) -import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import GHC.Hs -import GHC.Types.Name import GHC.Utils.Outputable ( ftext, showSDocUnsafe ) import GHC.Types.Basic -import qualified GHC.Types.SrcLoc - -import DataTreePrint diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs index 7aa2ed6..a214325 100644 --- a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -7,49 +7,10 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Data.Char import System.Random diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 6c52450..b6c4423 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -11,7 +11,6 @@ where import GHC.Hs.Extension as E ( GhcPs ) import GHC.Types.Name.Reader as E ( RdrName ) -import qualified GHC ( Located ) -- more general: @@ -56,21 +55,11 @@ import Data.Set as E ( Set ) import Data.Text as E ( Text ) -import Prelude as E ( Char - , String - , Int - , Integer - , Float - , Double - , Bool (..) - , undefined +import Prelude as E ( undefined , Eq (..) , Ord (..) , Enum (..) , Bounded (..) - , Maybe (..) - , Either (..) - , IO , (<$>) , (.) , ($) @@ -101,7 +90,6 @@ import Prelude as E ( Char , (||) , curry , uncurry - , Ordering (..) , flip , const , seq @@ -184,14 +172,12 @@ import Data.Word as E ( Word32 ) import Data.Ord as E ( comparing - , Down (..) ) import Data.Either as E ( either ) -import Data.Ratio as E ( Ratio - , (%) +import Data.Ratio as E ( (%) , numerator , denominator ) @@ -240,8 +226,7 @@ import Control.Concurrent as E ( threadDelay , forkOS ) -import Control.Concurrent.MVar as E ( MVar - , newEmptyMVar +import Control.Concurrent.MVar as E ( newEmptyMVar , newMVar , putMVar , readMVar @@ -273,7 +258,7 @@ import Data.Monoid as E ( mconcat ) import Data.Bifunctor as E ( bimap ) -import Data.Functor as E ( (<$), ($>) ) +import Data.Functor as E ( ($>) ) import Data.Function as E ( (&) ) import Data.Semigroup as E ( (<>) , Semigroup(..) @@ -293,12 +278,6 @@ import Control.Arrow as E ( first , (<<<) ) -import Data.Functor.Identity as E ( Identity (..) - ) - -import Data.Proxy as E ( Proxy (..) - ) - import Data.Version as E ( showVersion ) @@ -372,15 +351,6 @@ import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) -- , 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 (..) ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 7e5677b..79f4f38 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -11,49 +11,11 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Data.HList.ContainsType diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index f10853d..c1da956 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -6,53 +6,8 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 992d3b0..8ffb116 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -7,52 +7,9 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index f1c43b2..de5526f 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -6,53 +6,8 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs index f1b3973..7dc5c5a 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -6,57 +6,10 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types -import qualified Data.Generics.Uniplate.Direct as Uniplate - transformSimplifyPar :: BriDoc -> BriDoc diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index f04d2a6..c95aa7c 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -11,60 +11,20 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId, SrcSpan ) +import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan ) -import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) -import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey ) +import Language.Haskell.GHC.ExactPrint ( AnnKey ) +import Language.Haskell.GHC.ExactPrint.Types ( Anns ) import Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 43f9382..38cf006 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -34,61 +34,18 @@ where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import Data.Data -import Data.Generics.Schemes import Data.Generics.Aliases import qualified Text.PrettyPrint as PP -import Text.PrettyPrint ( ($+$), (<+>) ) import qualified GHC.Utils.Outputable as GHC import qualified GHC.Driver.Session as GHC diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs index 354c2ce..1ffa822 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ b/src/Language/Haskell/Brittany/Main.hs @@ -6,57 +6,18 @@ module Language.Haskell.Brittany.Main (main) where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate - as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Data.Map as Map import qualified Data.Monoid import GHC ( GenLocated(L) ) @@ -67,13 +28,10 @@ import GHC.Utils.Outputable ( Outputable import Text.Read ( Read(..) ) import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Data.Text.Lazy.Builder as Text.Builder import Control.Monad ( zipWithM ) import Data.CZipWith -import qualified Debug.Trace as Trace - import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Config -- 2.30.2 From e3deff448a0b6d7f05f1f3bfaf3b3ba950bbb773 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:35:09 +0000 Subject: [PATCH 417/478] Switch from `-Wall` to `-Weverything` --- brittany.cabal | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 0c447e9..5a4e662 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -84,8 +84,22 @@ library { Language.Haskell.Brittany.Internal.Transformations.Indent } ghc-options: { - -Wall - -fno-warn-redundant-constraints + -Weverything + -Wno-deriving-typeable + -Wno-incomplete-record-updates + -Wno-incomplete-uni-patterns + -Wno-missing-deriving-strategies + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-safe-haskell-mode + -Wno-monomorphism-restriction + -Wno-noncanonical-monad-instances + -Wno-noncanonical-monoid-instances + -Wno-prepositive-qualified-module + -Wno-redundant-constraints + -Wno-unsafe + -Wno-unused-packages } build-depends: { base ^>= 4.15.0 -- 2.30.2 From 325798a02bffb637ebf9fcba1e1310187e2b84ac Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:35:34 +0000 Subject: [PATCH 418/478] Remove unused dependencies --- brittany.cabal | 3 --- 1 file changed, 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 5a4e662..5fdcb02 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -99,7 +99,6 @@ library { -Wno-prepositive-qualified-module -Wno-redundant-constraints -Wno-unsafe - -Wno-unused-packages } build-depends: { base ^>= 4.15.0 @@ -117,7 +116,6 @@ library { , ghc ^>= 9.0.1 , ghc-boot-th ^>= 9.0.1 , ghc-exactprint ^>= 0.6.4 - , ghc-paths ^>= 0.1.0 , monad-memo ^>= 0.5.3 , mtl ^>= 2.2.2 , multistate ^>= 0.8.0 @@ -130,7 +128,6 @@ library { , text ^>= 1.2.5 , transformers ^>= 0.5.6 , uniplate ^>= 1.6.13 - , unsafe ^>= 0.0 , yaml ^>= 0.11.7 } default-extensions: { -- 2.30.2 From bb3a7d0a5b8cfc458dda415858aeb61a1c3ab98b Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:36:35 +0000 Subject: [PATCH 419/478] Remove unnecessary `Typeable` instances --- brittany.cabal | 1 - src/Language/Haskell/Brittany/Internal/Types.hs | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 5fdcb02..fda241c 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -85,7 +85,6 @@ library { } ghc-options: { -Weverything - -Wno-deriving-typeable -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns -Wno-missing-deriving-strategies diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index c95aa7c..5e2b1f7 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -217,7 +217,7 @@ data ColSig data BrIndent = BrIndentNone | BrIndentRegular | BrIndentSpecial Int - deriving (Eq, Ord, Typeable, Data.Data.Data, Show) + deriving (Eq, Ord, Data.Data.Data, Show) type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] -- reader @@ -231,7 +231,7 @@ type ToBriDocC sym c = Located sym -> ToBriDocM c data DocMultiLine = MultiLineNo | MultiLinePossible - deriving (Eq, Typeable) + deriving (Eq) -- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot -- of transformations on `BriDocF Identity`s and it is really annoying to -- 2.30.2 From 7ce87381ae5a5a2e92bd7637f2daf69d422c57b9 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:37:19 +0000 Subject: [PATCH 420/478] Use canonical `Monad` instance --- brittany.cabal | 1 - src/Language/Haskell/Brittany/Internal/PreludeUtils.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index fda241c..6b48791 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -93,7 +93,6 @@ library { -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction - -Wno-noncanonical-monad-instances -Wno-noncanonical-monoid-instances -Wno-prepositive-qualified-module -Wno-redundant-constraints diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs index df80168..445a0ab 100644 --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -23,7 +23,6 @@ instance Applicative Strict.Maybe where _ <*> _ = Strict.Nothing instance Monad Strict.Maybe where - return = Strict.Just Strict.Nothing >>= _ = Strict.Nothing Strict.Just x >>= f = f x -- 2.30.2 From ce0aa4feec8abc988845186e6792b9fc543daaf9 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:37:47 +0000 Subject: [PATCH 421/478] Use canonical `Monoid` instances --- brittany.cabal | 1 - src/Language/Haskell/Brittany/Internal/Config/Types.hs | 6 ------ 2 files changed, 7 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 6b48791..49cbbe0 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -93,7 +93,6 @@ library { -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction - -Wno-noncanonical-monoid-instances -Wno-prepositive-qualified-module -Wno-redundant-constraints -Wno-unsafe diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index e758b2e..791c241 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -264,22 +264,16 @@ instance Semigroup.Semigroup (CConfig Identity) where instance Monoid (CDebugConfig Maybe) where mempty = gmempty - mappend = gmappend instance Monoid (CLayoutConfig Maybe) where mempty = gmempty - mappend = gmappend instance Monoid (CErrorHandlingConfig Maybe) where mempty = gmempty - mappend = gmappend instance Monoid (CForwardOptions Maybe) where mempty = gmempty - mappend = gmappend instance Monoid (CPreProcessorConfig Maybe) where mempty = gmempty - mappend = gmappend instance Monoid (CConfig Maybe) where mempty = gmempty - mappend = gmappend data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more -- 2.30.2 From c02edecd1e3d80fa657b444b4e8c14b340b60284 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:39:57 +0000 Subject: [PATCH 422/478] Remove redundant constraints --- brittany.cabal | 1 - .../Haskell/Brittany/Internal/BackendUtils.hs | 46 ++++++------------- .../Brittany/Internal/LayouterBasics.hs | 2 +- .../Haskell/Brittany/Internal/Obfuscation.hs | 2 +- 4 files changed, 15 insertions(+), 36 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 49cbbe0..b257bd3 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -94,7 +94,6 @@ library { -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module - -Wno-redundant-constraints -Wno-unsafe } build-depends: diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 93b7dc7..6491b07 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -57,7 +57,7 @@ import GHC ( Located ) traceLocal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a) + :: (MonadMultiState LayoutState m) => a -> m () traceLocal _ = return () @@ -66,7 +66,6 @@ traceLocal _ = return () layoutWriteAppend :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => Text -> m () @@ -93,7 +92,6 @@ layoutWriteAppend t = do layoutWriteAppendSpaces :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => Int -> m () @@ -108,7 +106,6 @@ layoutWriteAppendSpaces i = do layoutWriteAppendMultiline :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => [Text] -> m () @@ -126,7 +123,6 @@ layoutWriteAppendMultiline ts = do layoutWriteNewlineBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => m () layoutWriteNewlineBlock = do @@ -151,7 +147,7 @@ layoutWriteNewlineBlock = do -- } layoutSetCommentCol - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () + :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol = do state <- mGet let col = case _lstate_curYOrAddNewline state of @@ -166,7 +162,6 @@ layoutSetCommentCol = do layoutMoveToCommentPos :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => Int -> Int @@ -199,7 +194,6 @@ layoutMoveToCommentPos y x commentLines = do layoutWriteNewline :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => m () layoutWriteNewline = do @@ -219,7 +213,6 @@ _layoutResetCommentNewlines = do layoutWriteEnsureNewlineBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => m () layoutWriteEnsureNewlineBlock = do @@ -236,7 +229,6 @@ layoutWriteEnsureNewlineBlock = do layoutWriteEnsureAbsoluteN :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => Int -> m () @@ -255,7 +247,7 @@ layoutWriteEnsureAbsoluteN n = do } layoutBaseYPushInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) + :: (MonadMultiState LayoutState m) => Int -> m () layoutBaseYPushInternal i = do @@ -263,13 +255,13 @@ layoutBaseYPushInternal i = do mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } layoutBaseYPopInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () + :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal = do traceLocal ("layoutBaseYPopInternal") mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) + :: (MonadMultiState LayoutState m) => Int -> m () layoutIndentLevelPushInternal i = do @@ -279,16 +271,14 @@ layoutIndentLevelPushInternal i = do } layoutIndentLevelPopInternal - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal = do traceLocal ("layoutIndentLevelPopInternal") mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s , _lstate_indLevels = List.tail $ _lstate_indLevels s } -layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) => m () +layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger = do mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } @@ -297,7 +287,6 @@ layoutWithAddBaseCol :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m , MonadMultiReader Config m - , MonadMultiWriter (Seq String) m ) => m () -> m () @@ -312,7 +301,6 @@ layoutWithAddBaseColBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m , MonadMultiReader Config m - , MonadMultiWriter (Seq String) m ) => m () -> m () @@ -327,7 +315,6 @@ layoutWithAddBaseColBlock m = do layoutWithAddBaseColNBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => Int -> m () @@ -343,7 +330,6 @@ layoutWithAddBaseColNBlock amount m = do layoutWriteEnsureBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => m () layoutWriteEnsureBlock = do @@ -362,7 +348,6 @@ layoutWriteEnsureBlock = do layoutWithAddBaseColN :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => Int -> m () @@ -374,7 +359,7 @@ layoutWithAddBaseColN amount m = do layoutBaseYPopInternal layoutBaseYPushCur - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () + :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur = do traceLocal ("layoutBaseYPushCur") state <- mGet @@ -387,13 +372,13 @@ layoutBaseYPushCur = do Just cCol -> layoutBaseYPushInternal cCol layoutBaseYPop - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () + :: (MonadMultiState LayoutState m) => m () layoutBaseYPop = do traceLocal ("layoutBaseYPop") layoutBaseYPopInternal layoutIndentLevelPushCur - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur = do traceLocal ("layoutIndentLevelPushCur") state <- mGet @@ -405,7 +390,7 @@ layoutIndentLevelPushCur = do layoutIndentLevelPushInternal y layoutIndentLevelPop - :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") layoutIndentLevelPopInternal @@ -415,8 +400,7 @@ layoutIndentLevelPop = do -- make sense. layoutRemoveIndentLevelLinger -layoutAddSepSpace :: (MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) +layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () layoutAddSepSpace = do state <- mGet @@ -429,7 +413,6 @@ moveToExactAnn :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m , MonadMultiReader (Map AnnKey Annotation) m - , MonadMultiWriter (Seq String) m ) => AnnKey -> m () @@ -480,7 +463,6 @@ layoutWritePriorComments :: ( Data.Data.Data ast , MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) => Located ast -> m () @@ -512,8 +494,7 @@ layoutWritePriorComments ast = do -- "..`annFollowingComments` are only added by AST transformations ..". layoutWritePostComments :: (Data.Data.Data ast, MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) + MonadMultiState LayoutState m) => Located ast -> m () layoutWritePostComments ast = do mAnn <- do @@ -543,7 +524,6 @@ layoutWritePostComments ast = do layoutIndentRestorePostComment :: ( MonadMultiState LayoutState m , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m ) => m () layoutIndentRestorePostComment = do diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 296f3ba..8050c00 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -177,7 +177,7 @@ briDocByExactNoComment ast = do -- not contain any newlines. If this property is not met, the semantics -- depend on the @econf_AllowRiskyExactPrintUse@ config flag. briDocByExactInlineOnly - :: (ExactPrint.Annotate.Annotate ast, Data ast) + :: (ExactPrint.Annotate.Annotate ast) => String -> Located ast -> ToBriDocM BriDocNumbered diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs index a214325..67312b3 100644 --- a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -96,7 +96,7 @@ _randomRange lo hi = do setStdGen gen' pure x -randomFrom :: Random a => [a] -> IO a +randomFrom :: [a] -> IO a randomFrom l = do let hi = length l - 1 gen <- getStdGen -- 2.30.2 From 2dced782b1d210156797fdf2b65460acac3bcd09 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:40:55 +0000 Subject: [PATCH 423/478] Make sure record updates are complete --- brittany.cabal | 1 - src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index b257bd3..969b882 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -85,7 +85,6 @@ library { } ghc-options: { -Weverything - -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns -Wno-missing-deriving-strategies -Wno-missing-export-lists diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 47a9514..f068b6c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -863,7 +863,7 @@ layoutClsInst lcid@(L _ cid) = docLines . removeChildren <$> lcid - removeChildren :: ClsInstDecl p -> ClsInstDecl p + removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c { cid_binds = emptyBag , cid_sigs = [] -- 2.30.2 From 72fd6959f76e451a6f5db7d455fd5d3ee47f492b Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:45:56 +0000 Subject: [PATCH 424/478] Don't enable any language extensions by default --- .hlint.yaml | 6 +----- brittany.cabal | 15 --------------- src/Language/Haskell/Brittany.hs | 10 ++++++++++ src/Language/Haskell/Brittany/Internal.hs | 10 ++++++++++ src/Language/Haskell/Brittany/Internal/Backend.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/BackendUtils.hs | 10 ++++++++++ src/Language/Haskell/Brittany/Internal/Config.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/Config/Types.hs | 10 ++++++++++ .../Brittany/Internal/Config/Types/Instances.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/ExactPrintUtils.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/LayouterBasics.hs | 10 ++++++++++ .../Brittany/Internal/Layouters/DataDecl.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Decl.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 10 ++++++++++ .../Brittany/Internal/Layouters/Expr.hs-boot | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Import.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Module.hs | 10 ++++++++++ .../Brittany/Internal/Layouters/Pattern.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Stmt.hs | 10 ++++++++++ .../Brittany/Internal/Layouters/Stmt.hs-boot | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Type.hs | 10 ++++++++++ .../Haskell/Brittany/Internal/Obfuscation.hs | 10 ++++++++++ .../Brittany/Internal/Transformations/Alt.hs | 10 ++++++++++ .../Brittany/Internal/Transformations/Columns.hs | 10 ++++++++++ .../Brittany/Internal/Transformations/Floating.hs | 10 ++++++++++ .../Brittany/Internal/Transformations/Indent.hs | 10 ++++++++++ .../Brittany/Internal/Transformations/Par.hs | 10 ++++++++++ src/Language/Haskell/Brittany/Internal/Types.hs | 10 ++++++++++ src/Language/Haskell/Brittany/Internal/Utils.hs | 10 ++++++++++ src/Language/Haskell/Brittany/Main.hs | 10 ++++++++++ 31 files changed, 291 insertions(+), 20 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 1aaea27..9c4c809 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -8,11 +8,7 @@ # Specify additional command line arguments - arguments: - [ "--language=GADTs" - , "--language=LambdaCase" - , "--language=MultiWayIf" - , "--language=KindSignatures" - , "--cross" + [ "--cross" , "--threads=0" ] diff --git a/brittany.cabal b/brittany.cabal index 969b882..a7e5c58 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -125,21 +125,6 @@ library { , uniplate ^>= 1.6.13 , yaml ^>= 0.11.7 } - default-extensions: { - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } } executable brittany diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index a4fc839..5e640e8 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 81c7733..bdcab84 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 92c29fb..68e414c 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeOperators #-} diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 6491b07..f53a3a9 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeApplications #-} diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 22d7163..09b6ed3 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Config ( CConfig(..) , CDebugConfig(..) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 791c241..49e0c2b 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 0ad985c..7a5638d 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -13,6 +13,16 @@ {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fignore-interface-pragmas #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Config.Types.Instances where diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index c17e8b1..2bfeed4 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.ExactPrintUtils diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 8050c00..9c20b57 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.Haskell.Brittany.Internal.LayouterBasics diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 59a54bb..cbd9b21 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index f068b6c..25bacc5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE PatternSynonyms #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index f2b9674..13a7bae 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE ViewPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 1c748f0..f9ceb4f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.Layouters.Expr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index b7b3bb3..620de4a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Layouters.IE ( layoutIE , layoutLLIEs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 128c13f..385983e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where import Language.Haskell.Brittany.Internal.Prelude diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 48d789b..4efb2c1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 9bc39cf..80a1337 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE ViewPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 2af1ada..8012ba6 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.Layouters.Stmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 1b35a55..7c1f0ff 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.Layouters.Stmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 4aead4e..7f46688 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.Layouters.Type diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs index 67312b3..79c8337 100644 --- a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Obfuscation ( obfuscate ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 79f4f38..0746a8c 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index c1da956..c76f31c 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Transformations.Columns ( transformSimplifyColumns ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 8ffb116..4b68bb9 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Transformations.Floating ( transformSimplifyFloating ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index de5526f..816aecb 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Transformations.Indent ( transformSimplifyIndent ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 7dc5c5a..8e686ce 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Language.Haskell.Brittany.Internal.Transformations.Par ( transformSimplifyPar ) diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 5e2b1f7..1e2dcbc 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index 38cf006..c67716a 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs index 1ffa822..c86c90e 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ b/src/Language/Haskell/Brittany/Main.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Main (main) where -- 2.30.2 From 09fabe8d163ee4a398df58e70186cc7e11375c58 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:47:27 +0000 Subject: [PATCH 425/478] Compress executable artifacts --- .github/workflows/ci.yaml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 0189cb7..cc3cd3e 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -11,14 +11,10 @@ jobs: strategy: fail-fast: false matrix: - os: - - macos-11 - - ubuntu-20.04 - - windows-2019 - ghc: - - 9.0.1 - cabal: - - 3.6.2.0 + include: + - { os: macos-11, ghc: 9.0.1, cabal: 3.6.2.0 } + - { os: ubuntu-20.04, ghc: 9.0.1, cabal: 3.6.2.0 } + - { os: windows-2019, ghc: 9.0.1, cabal: 3.6.2.0, ext: .exe } runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 @@ -44,6 +40,10 @@ jobs: - run: cabal test --test-show-details direct - run: cabal check - run: cabal sdist --output-dir artifact/${{ matrix.os }} + - uses: svenstaro/upx-action@v2 + with: + file: artifact/${{ matrix.os }}/brittany${{ matrix.ext }} + args: --best - uses: actions/upload-artifact@v2 with: path: artifact -- 2.30.2 From 09f7e1726b1653036e874b47c1d3cd8ebcc2731f Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 17:59:26 +0000 Subject: [PATCH 426/478] Configure HLint --- .hlint.yaml | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/.hlint.yaml b/.hlint.yaml index 9c4c809..9a788b8 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -17,3 +17,46 @@ - ignore: {name: "Redundant do"} - ignore: {name: "Redundant return"} - ignore: {name: "Redundant guard", whithin: "lrdrNameToTextAnn"} + +- ignore: { name: 'Use :' } +- ignore: { name: Avoid lambda } +- ignore: { name: Eta reduce } +- ignore: { name: Move brackets to avoid $ } +- ignore: { name: Redundant <$> } +- ignore: { name: Redundant $ } +- ignore: { name: Redundant bang pattern } +- ignore: { name: Redundant bracket } +- ignore: { name: Redundant flip } +- ignore: { name: Redundant id } +- ignore: { name: Redundant if } +- ignore: { name: Redundant lambda } +- ignore: { name: Replace case with fromMaybe } +- ignore: { name: Unused LANGUAGE pragma } +- ignore: { name: Use <=< } +- ignore: { name: Use <$> } +- ignore: { name: Use all } +- ignore: { name: Use and } +- ignore: { name: Use any } +- ignore: { name: Use concatMap } +- ignore: { name: Use const } +- ignore: { name: Use elem } +- ignore: { name: Use elemIndex } +- ignore: { name: Use fewer imports } +- ignore: { name: Use fewer LANGUAGE pragmas } +- ignore: { name: Use first } +- ignore: { name: Use fromLeft } +- ignore: { name: Use getContents } +- ignore: { name: Use if } +- ignore: { name: Use isNothing } +- ignore: { name: Use lambda-case } +- ignore: { name: Use mapM } +- ignore: { name: Use minimumBy } +- ignore: { name: Use newtype instead of data } +- ignore: { name: Use record patterns } +- ignore: { name: Use second } +- ignore: { name: Use section } +- ignore: { name: Use sortOn } +- ignore: { name: Use sqrt } +- ignore: { name: Use tuple-section } +- ignore: { name: Use unless } +- ignore: { name: Use when } -- 2.30.2 From d1968b5de3cd7218e98ab8f3cd38ceb25a3f0f02 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 18:17:01 +0000 Subject: [PATCH 427/478] Remove redundant language extensions --- .hlint.yaml | 2 -- src-idemtests/cases/LayoutBasics.hs | 18 ++---------------- src-literatetests/Main.hs | 3 --- src-unittests/AsymptoticPerfTests.hs | 2 -- src-unittests/TestMain.hs | 2 -- src-unittests/TestUtils.hs | 2 -- src/Language/Haskell/Brittany.hs | 10 ---------- src/Language/Haskell/Brittany/Internal.hs | 8 -------- .../Haskell/Brittany/Internal/Backend.hs | 13 +------------ .../Haskell/Brittany/Internal/BackendUtils.hs | 11 ----------- .../Haskell/Brittany/Internal/Config.hs | 7 ------- .../Haskell/Brittany/Internal/Config/Types.hs | 19 +++++-------------- .../Internal/Config/Types/Instances.hs | 7 ------- .../Brittany/Internal/ExactPrintUtils.hs | 7 +------ .../Brittany/Internal/LayouterBasics.hs | 10 ++-------- .../Brittany/Internal/Layouters/DataDecl.hs | 12 ------------ .../Brittany/Internal/Layouters/Decl.hs | 11 ----------- .../Brittany/Internal/Layouters/Expr.hs | 9 --------- .../Brittany/Internal/Layouters/Expr.hs-boot | 10 ---------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 6 ------ .../Brittany/Internal/Layouters/Import.hs | 8 -------- .../Brittany/Internal/Layouters/Module.hs | 9 --------- .../Brittany/Internal/Layouters/Pattern.hs | 10 ---------- .../Brittany/Internal/Layouters/Stmt.hs | 8 -------- .../Brittany/Internal/Layouters/Stmt.hs-boot | 10 ---------- .../Brittany/Internal/Layouters/Type.hs | 9 --------- .../Haskell/Brittany/Internal/Obfuscation.hs | 8 -------- .../Brittany/Internal/Transformations/Alt.hs | 17 ++++++----------- .../Internal/Transformations/Columns.hs | 7 ------- .../Internal/Transformations/Floating.hs | 7 ------- .../Internal/Transformations/Indent.hs | 7 ------- .../Brittany/Internal/Transformations/Par.hs | 7 ------- .../Haskell/Brittany/Internal/Types.hs | 16 ++++++---------- .../Haskell/Brittany/Internal/Utils.hs | 11 ++--------- src/Language/Haskell/Brittany/Main.hs | 8 -------- 35 files changed, 25 insertions(+), 286 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 9a788b8..026d8f1 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -31,7 +31,6 @@ - ignore: { name: Redundant if } - ignore: { name: Redundant lambda } - ignore: { name: Replace case with fromMaybe } -- ignore: { name: Unused LANGUAGE pragma } - ignore: { name: Use <=< } - ignore: { name: Use <$> } - ignore: { name: Use all } @@ -42,7 +41,6 @@ - ignore: { name: Use elem } - ignore: { name: Use elemIndex } - ignore: { name: Use fewer imports } -- ignore: { name: Use fewer LANGUAGE pragmas } - ignore: { name: Use first } - ignore: { name: Use fromLeft } - ignore: { name: Use getContents } diff --git a/src-idemtests/cases/LayoutBasics.hs b/src-idemtests/cases/LayoutBasics.hs index 3664d3e..d1331a5 100644 --- a/src-idemtests/cases/LayoutBasics.hs +++ b/src-idemtests/cases/LayoutBasics.hs @@ -1,17 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE KindSignatures #-} - module Language.Haskell.Brittany.Internal.LayoutBasics ( processDefault , layoutByExact @@ -210,7 +196,7 @@ descToMinMax _ _ = rdrNameToText :: RdrName -> Text -- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr rdrNameToText ( Unqual occname ) = Text.pack $ occNameString occname -rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname +rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname ++ "." ++ occNameString occname rdrNameToText ( Orig modul occname ) = Text.pack $ moduleNameString (moduleName modul) @@ -264,7 +250,7 @@ calcLayoutMin indent linePre (LayoutDesc line block) = case (line, block) of (Just s, _) -> indent + _lColumns_min s _ -> error "bad LayoutDesc mnasdoiucxvlkjasd" --- see +-- see calcLayoutMax :: Int -- basic indentation amount -> Int -- currently used width in current line (after indent) -- used to accurately calc placing of the current-line diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index bc860ce..2cb903c 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} - module Main ( main ) diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs index 636ff89..886c3e7 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module AsymptoticPerfTests ( asymptoticPerfTest ) diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs index 66eaed2..7fa2fa4 100644 --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module Main where diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index a8b8e2e..94c2375 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module TestUtils where diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 5e640e8..8c225c6 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -1,14 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany ( parsePrintModule diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index bdcab84..41ac6b1 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -1,15 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} - module Language.Haskell.Brittany.Internal ( parsePrintModule , parsePrintModuleTests diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 68e414c..204a16f 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -1,20 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ConstraintKinds #-} - module Language.Haskell.Brittany.Internal.Backend ( layoutBriDocM ) diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index f53a3a9..444d548 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -1,16 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeApplications #-} module Language.Haskell.Brittany.Internal.BackendUtils ( layoutWriteAppend diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 09b6ed3..c243e20 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -1,12 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Config ( CConfig(..) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 49e0c2b..30d32c3 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -1,18 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} module Language.Haskell.Brittany.Internal.Config.Types ( module Language.Haskell.Brittany.Internal.Config.Types diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 7a5638d..97484b4 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -13,15 +13,8 @@ {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fignore-interface-pragmas #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Config.Types.Instances where diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 2bfeed4..4c281aa 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -1,15 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} - module Language.Haskell.Brittany.Internal.ExactPrintUtils ( parseModule , parseModuleFromString diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 9c20b57..e89549f 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -1,14 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.Haskell.Brittany.Internal.LayouterBasics ( processDefault diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index cbd9b21..6a5af9b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -1,17 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE KindSignatures #-} module Language.Haskell.Brittany.Internal.Layouters.DataDecl ( layoutDataDecl diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 25bacc5..a9621f4 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -1,19 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} - module Language.Haskell.Brittany.Internal.Layouters.Decl ( layoutDecl , layoutSig diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 13a7bae..564fe3f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -1,15 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Expr ( layoutExpr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index f9ceb4f..5ee3716 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -1,14 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.Layouters.Expr ( layoutExpr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 620de4a..481a030 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -1,12 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Layouters.IE ( layoutIE diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 385983e..2a1edf5 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -1,12 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 4efb2c1..00c3bfd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -1,14 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 80a1337..6ea00a1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -1,15 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Pattern ( layoutPat diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 8012ba6..73bc785 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -1,15 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} - module Language.Haskell.Brittany.Internal.Layouters.Stmt ( layoutStmt ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 7c1f0ff..8b6c000 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -1,14 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.Layouters.Stmt ( layoutStmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 7f46688..63fa20a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -1,14 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Internal.Layouters.Type ( layoutType diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs index 79c8337..427fe43 100644 --- a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -1,12 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Obfuscation ( obfuscate diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 0746a8c..4dfbba2 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -1,16 +1,11 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Language.Haskell.Brittany.Internal.Transformations.Alt ( transformAlts diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index c76f31c..732e6a1 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -1,12 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Transformations.Columns ( transformSimplifyColumns diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 4b68bb9..87d551d 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -1,12 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Transformations.Floating ( transformSimplifyFloating diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 816aecb..e39790a 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -1,12 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Transformations.Indent ( transformSimplifyIndent diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 8e686ce..eb186f4 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -1,12 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal.Transformations.Par ( transformSimplifyPar diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 1e2dcbc..db9e36d 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -1,19 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} module Language.Haskell.Brittany.Internal.Types where diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index c67716a..a18f874 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -1,17 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.Haskell.Brittany.Internal.Utils ( parDoc , parDocW diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs index c86c90e..e1d482b 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ b/src/Language/Haskell/Brittany/Main.hs @@ -1,14 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany.Main (main) where -- 2.30.2 From 8a4bfe083e5d3fb2b6541a3c3731689851e71caf Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 20:12:17 +0000 Subject: [PATCH 428/478] Use layout for package description --- brittany.cabal | 80 ++++++++++++++++++-------------------------------- 1 file changed, 28 insertions(+), 52 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index a7e5c58..4e31764 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,13 +1,12 @@ name: brittany version: 0.13.1.2 synopsis: Haskell source code formatter -description: { +description: See . . If you are interested in the implementation, have a look at ; . The implementation is documented in more detail . -} license: AGPL-3 license-file: LICENSE author: Lennart Spitzner @@ -19,19 +18,16 @@ build-type: Simple cabal-version: 2.0 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues -extra-doc-files: { +extra-doc-files: ChangeLog.md README.md doc/implementation/*.md -} -extra-source-files: { +extra-source-files: src-literatetests/*.blt -} -source-repository head { +source-repository head type: git location: https://github.com/lspitzner/brittany.git -} flag brittany-dev-lib description: set buildable false for anything but lib @@ -43,12 +39,12 @@ flag brittany-test-perf default: False manual: True -library { +library default-language: Haskell2010 hs-source-dirs: src - exposed-modules: { + exposed-modules: Language.Haskell.Brittany Language.Haskell.Brittany.Main Language.Haskell.Brittany.Internal @@ -61,9 +57,8 @@ library { Language.Haskell.Brittany.Internal.Config.Types.Instances Language.Haskell.Brittany.Internal.Obfuscation Paths_brittany - } autogen-modules: Paths_brittany - other-modules: { + other-modules: Language.Haskell.Brittany.Internal.LayouterBasics Language.Haskell.Brittany.Internal.Backend Language.Haskell.Brittany.Internal.BackendUtils @@ -82,8 +77,7 @@ library { Language.Haskell.Brittany.Internal.Transformations.Par Language.Haskell.Brittany.Internal.Transformations.Columns Language.Haskell.Brittany.Internal.Transformations.Indent - } - ghc-options: { + ghc-options: -Weverything -Wno-incomplete-uni-patterns -Wno-missing-deriving-strategies @@ -94,9 +88,8 @@ library { -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unsafe - } build-depends: - { base ^>= 4.15.0 + base ^>= 4.15.0 , aeson ^>= 2.0.1 , butcher ^>= 1.3.3 , bytestring ^>= 0.10.12 @@ -124,41 +117,35 @@ library { , transformers ^>= 0.5.6 , uniplate ^>= 1.6.13 , yaml ^>= 0.11.7 - } -} executable brittany - if flag(brittany-dev-lib) { + if flag(brittany-dev-lib) buildable: False - } else { + else buildable: True - } main-is: Main.hs hs-source-dirs: src-brittany build-depends: - { base + base , brittany - } default-language: Haskell2010 - ghc-options: { + ghc-options: -Wall -fno-spec-constr -fno-warn-unused-imports -fno-warn-redundant-constraints -rtsopts -with-rtsopts "-M2G" - } test-suite unittests - if flag(brittany-dev-lib) || !flag(brittany-test-perf) { + if flag(brittany-dev-lib) || !flag(brittany-test-perf) buildable: False - } else { + else buildable: True - } type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: - { brittany + brittany , base , ghc , ghc-paths @@ -188,12 +175,11 @@ test-suite unittests , czipwith , ghc-boot-th , hspec >=2.4.1 && <2.9 - } main-is: TestMain.hs other-modules: TestUtils AsymptoticPerfTests hs-source-dirs: src-unittests - default-extensions: { + default-extensions: CPP NoImplicitPrelude @@ -207,8 +193,7 @@ test-suite unittests LambdaCase MultiWayIf KindSignatures - } - ghc-options: { + ghc-options: -Wall -fno-warn-unused-imports -rtsopts @@ -217,18 +202,16 @@ test-suite unittests -- ^ threaded is not necessary at all, but our CI trusts on being able -- to pass -N1, which is not possible without threaded :-/ -- (plus -no-threaded is not a thing, afaict) - } test-suite littests - if flag(brittany-dev-lib) { + if flag(brittany-dev-lib) buildable: False - } else { + else buildable: True - } type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: - { brittany + brittany , base , ghc , ghc-paths @@ -260,11 +243,10 @@ test-suite littests , hspec >=2.4.1 && <2.9 , filepath , parsec >=3.1.11 && <3.2 - } main-is: Main.hs other-modules: hs-source-dirs: src-literatetests - default-extensions: { + default-extensions: CPP NoImplicitPrelude @@ -278,34 +260,30 @@ test-suite littests LambdaCase MultiWayIf KindSignatures - } - ghc-options: { + ghc-options: -Wall -fno-warn-unused-imports -threaded -rtsopts -with-rtsopts "-M2G -N" - } test-suite libinterfacetests - if flag(brittany-dev-lib) { + if flag(brittany-dev-lib) buildable: False - } else { + else buildable: True - } type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: - { brittany + brittany , base , text , transformers , hspec >=2.4.1 && <2.9 - } main-is: Main.hs other-modules: hs-source-dirs: src-libinterfacetests - default-extensions: { + default-extensions: FlexibleContexts FlexibleInstances ScopedTypeVariables @@ -313,8 +291,7 @@ test-suite libinterfacetests LambdaCase MultiWayIf KindSignatures - } - ghc-options: { + ghc-options: -Wall -fno-warn-unused-imports -rtsopts @@ -323,4 +300,3 @@ test-suite libinterfacetests -- ^ threaded is not necessary at all, but our CI trusts on being able -- to pass -N1, which is not possible without threaded :-/ -- (plus -no-threaded is not a thing, afaict) - } -- 2.30.2 From 33d2aa87906bd036d8b0bde614978fd70dc8b6d2 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 20:33:43 +0000 Subject: [PATCH 429/478] Use common stanzas in package description --- brittany.cabal | 268 ++++++++------------------- src-libinterfacetests/Main.hs | 1 - src-literatetests/Main.hs | 47 +---- src-unittests/AsymptoticPerfTests.hs | 59 +----- src-unittests/TestMain.hs | 49 ----- src-unittests/TestUtils.hs | 41 ---- 6 files changed, 86 insertions(+), 379 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 4e31764..83893e4 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,3 +1,5 @@ +cabal-version: 2.2 + name: brittany version: 0.13.1.2 synopsis: Haskell source code formatter @@ -7,7 +9,7 @@ description: If you are interested in the implementation, have a look at ; . The implementation is documented in more detail . -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner @@ -15,7 +17,6 @@ copyright: Copyright (C) 2016-2019 Lennart Spitzner Copyright (C) 2019 PRODA LTD category: Language build-type: Simple -cabal-version: 2.0 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues extra-doc-files: @@ -39,9 +40,62 @@ flag brittany-test-perf default: False manual: True +common library + build-depends: + , aeson ^>= 2.0.1 + , base ^>= 4.15.0 + , butcher ^>= 1.3.3 + , bytestring ^>= 0.10.12 + , cmdargs ^>= 0.10.21 + , containers ^>= 0.6.4 + , czipwith ^>= 1.0.1 + , data-tree-print ^>= 0.1.0 + , deepseq ^>= 1.4.5 + , directory ^>= 1.3.6 + , extra ^>= 1.7.10 + , filepath ^>= 1.4.2 + , ghc ^>= 9.0.1 + , ghc-boot-th ^>= 9.0.1 + , ghc-exactprint ^>= 0.6.4 + , monad-memo ^>= 0.5.3 + , mtl ^>= 2.2.2 + , multistate ^>= 0.8.0 + , pretty ^>= 1.1.3 + , random ^>= 1.2.1 + , safe ^>= 0.3.19 + , semigroups ^>= 0.19.2 + , strict ^>= 0.4.0 + , syb ^>= 0.7.2 + , text ^>= 1.2.5 + , transformers ^>= 0.5.6 + , uniplate ^>= 1.6.13 + , yaml ^>= 0.11.7 + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-incomplete-uni-patterns + -Wno-missing-deriving-strategies + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-safe-haskell-mode + -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module + -Wno-unsafe + +common executable + import: library + + build-depends: brittany + ghc-options: + -rtsopts + -threaded + -Wno-implicit-prelude + -Wno-unused-packages + library - default-language: - Haskell2010 + import: library + hs-source-dirs: src exposed-modules: @@ -77,226 +131,52 @@ library Language.Haskell.Brittany.Internal.Transformations.Par Language.Haskell.Brittany.Internal.Transformations.Columns Language.Haskell.Brittany.Internal.Transformations.Indent - ghc-options: - -Weverything - -Wno-incomplete-uni-patterns - -Wno-missing-deriving-strategies - -Wno-missing-export-lists - -Wno-missing-import-lists - -Wno-missing-local-signatures - -Wno-missing-safe-haskell-mode - -Wno-monomorphism-restriction - -Wno-prepositive-qualified-module - -Wno-unsafe - build-depends: - base ^>= 4.15.0 - , aeson ^>= 2.0.1 - , butcher ^>= 1.3.3 - , bytestring ^>= 0.10.12 - , cmdargs ^>= 0.10.21 - , containers ^>= 0.6.4 - , czipwith ^>= 1.0.1 - , data-tree-print ^>= 0.1.0 - , deepseq ^>= 1.4.5 - , directory ^>= 1.3.6 - , extra ^>= 1.7.10 - , filepath ^>= 1.4.2 - , ghc ^>= 9.0.1 - , ghc-boot-th ^>= 9.0.1 - , ghc-exactprint ^>= 0.6.4 - , monad-memo ^>= 0.5.3 - , mtl ^>= 2.2.2 - , multistate ^>= 0.8.0 - , pretty ^>= 1.1.3 - , random ^>= 1.2.1 - , safe ^>= 0.3.19 - , semigroups ^>= 0.19.2 - , strict ^>= 0.4.0 - , syb ^>= 0.7.2 - , text ^>= 1.2.5 - , transformers ^>= 0.5.6 - , uniplate ^>= 1.6.13 - , yaml ^>= 0.11.7 executable brittany + import: executable + if flag(brittany-dev-lib) buildable: False - else - buildable: True + main-is: Main.hs hs-source-dirs: src-brittany - build-depends: - base - , brittany - default-language: Haskell2010 - ghc-options: - -Wall - -fno-spec-constr - -fno-warn-unused-imports - -fno-warn-redundant-constraints - -rtsopts - -with-rtsopts "-M2G" test-suite unittests + import: executable + if flag(brittany-dev-lib) || !flag(brittany-test-perf) buildable: False - else - buildable: True + type: exitcode-stdio-1.0 - default-language: Haskell2010 build-depends: - brittany - , base - , ghc - , ghc-paths - , ghc-exactprint - , transformers - , containers - , mtl - , text - , multistate - , syb - , data-tree-print - , pretty - , bytestring - , directory - , butcher - , yaml - , aeson - , extra - , uniplate - , strict - , monad-memo - , unsafe - , safe - , deepseq - , semigroups - , cmdargs - , czipwith - , ghc-boot-th - , hspec >=2.4.1 && <2.9 + , hspec ^>= 2.8.3 main-is: TestMain.hs other-modules: TestUtils AsymptoticPerfTests hs-source-dirs: src-unittests - default-extensions: - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - ghc-options: - -Wall - -fno-warn-unused-imports - -rtsopts - -with-rtsopts "-M2G" - -threaded - -- ^ threaded is not necessary at all, but our CI trusts on being able - -- to pass -N1, which is not possible without threaded :-/ - -- (plus -no-threaded is not a thing, afaict) test-suite littests + import: executable + if flag(brittany-dev-lib) buildable: False - else - buildable: True + type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: - brittany - , base - , ghc - , ghc-paths - , ghc-exactprint - , transformers - , containers - , mtl - , text - , multistate - , syb - , data-tree-print - , pretty - , bytestring - , directory - , butcher - , yaml - , aeson - , extra - , uniplate - , strict - , monad-memo - , unsafe - , safe - , deepseq - , semigroups - , cmdargs - , czipwith - , ghc-boot-th - , hspec >=2.4.1 && <2.9 - , filepath - , parsec >=3.1.11 && <3.2 + , hspec ^>= 2.8.3 + , parsec ^>= 3.1.14 main-is: Main.hs - other-modules: hs-source-dirs: src-literatetests - default-extensions: - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - ghc-options: - -Wall - -fno-warn-unused-imports - -threaded - -rtsopts - -with-rtsopts "-M2G -N" test-suite libinterfacetests + import: executable + if flag(brittany-dev-lib) buildable: False - else - buildable: True + type: exitcode-stdio-1.0 - default-language: Haskell2010 build-depends: - brittany - , base - , text - , transformers - , hspec >=2.4.1 && <2.9 + , hspec ^>= 2.8.3 main-is: Main.hs - other-modules: hs-source-dirs: src-libinterfacetests - default-extensions: - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - ghc-options: - -Wall - -fno-warn-unused-imports - -rtsopts - -with-rtsopts "-M2G" - -threaded - -- ^ threaded is not necessary at all, but our CI trusts on being able - -- to pass -N1, which is not possible without threaded :-/ - -- (plus -no-threaded is not a thing, afaict) diff --git a/src-libinterfacetests/Main.hs b/src-libinterfacetests/Main.hs index 973755e..f663174 100644 --- a/src-libinterfacetests/Main.hs +++ b/src-libinterfacetests/Main.hs @@ -5,7 +5,6 @@ module Main where import Test.Hspec import Language.Haskell.Brittany import qualified Data.Text as Text -import qualified System.Exit as Exit import Control.Monad.IO.Class diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 2cb903c..399c08e 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} + module Main ( main ) @@ -6,61 +10,18 @@ where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS import qualified Data.List.Extra -import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO import qualified GHC.OldList as List -import qualified Safe as Safe import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Test.Hspec -import Test.Hspec.Runner ( hspecWith - , defaultConfig - , configConcurrentJobs - ) import qualified Text.Parsec as Parsec import Text.Parsec.Text ( Parser ) -import Data.Char ( isSpace ) import Data.List ( groupBy ) import Language.Haskell.Brittany.Internal diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs index 886c3e7..6abbf90 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module AsymptoticPerfTests ( asymptoticPerfTest ) @@ -5,71 +7,26 @@ where -import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Test.Hspec -import Language.Haskell.Brittany.Internal - import TestUtils asymptoticPerfTest :: Spec asymptoticPerfTest = do - it "1000 do statements" + it "10 do statements" $ roundTripEqualWithTimeout 1500000 $ (Text.pack "func = do\n") - <> Text.replicate 1000 (Text.pack " statement\n") - it "1000 do nestings" + <> Text.replicate 10 (Text.pack " statement\n") + it "10 do nestings" $ roundTripEqualWithTimeout 4000000 $ (Text.pack "func = ") <> mconcat - ( [0 .. 999] + ( [1 .. 10] <&> \(i :: Int) -> (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") ) @@ -77,7 +34,7 @@ asymptoticPerfTest = do <> Text.pack "return\n" <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" - it "1000 AppOps" + it "10 AppOps" $ roundTripEqualWithTimeout 1000000 $ (Text.pack "func = expr") - <> Text.replicate 200 (Text.pack "\n . expr") --TODO + <> Text.replicate 10 (Text.pack "\n . expr") --TODO diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs index 7fa2fa4..81ec429 100644 --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -1,57 +1,8 @@ module Main where - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass - import Test.Hspec -import Language.Haskell.Brittany.Internal - import AsymptoticPerfTests diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 94c2375..942f4aa 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -3,50 +3,9 @@ module TestUtils where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Control.Monad.Reader.Class as Reader.Class -import qualified Control.Monad.RWS.Class as RWS.Class -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT -import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -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.Writer.Class as Writer.Class -import qualified Data.Bool as Bool -import qualified Data.ByteString -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy as ByteStringL -import qualified Data.Coerce -import qualified Data.Data -import qualified Data.Either -import qualified Data.Foldable -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.List.Extra -import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL.Encoding -import qualified Data.Text.Lazy.IO as TextL.IO -import qualified GHC.OldList as List -import qualified Safe as Safe -import qualified System.Directory -import qualified System.IO -import qualified Text.PrettyPrint -import qualified Text.PrettyPrint.Annotated -import qualified Text.PrettyPrint.Annotated.HughesPJ -import qualified Text.PrettyPrint.Annotated.HughesPJClass import Test.Hspec -- 2.30.2 From 69e0f9fedf3b5f9d4b58bbd6554d1913c3b861df Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 20:34:25 +0000 Subject: [PATCH 430/478] Expose all modules --- brittany.cabal | 35 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 83893e4..780ccaf 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -100,37 +100,36 @@ library src exposed-modules: Language.Haskell.Brittany - Language.Haskell.Brittany.Main Language.Haskell.Brittany.Internal - Language.Haskell.Brittany.Internal.Prelude - Language.Haskell.Brittany.Internal.PreludeUtils - Language.Haskell.Brittany.Internal.Types - Language.Haskell.Brittany.Internal.Utils + Language.Haskell.Brittany.Internal.Backend + Language.Haskell.Brittany.Internal.BackendUtils Language.Haskell.Brittany.Internal.Config Language.Haskell.Brittany.Internal.Config.Types Language.Haskell.Brittany.Internal.Config.Types.Instances - Language.Haskell.Brittany.Internal.Obfuscation - Paths_brittany - autogen-modules: Paths_brittany - other-modules: - Language.Haskell.Brittany.Internal.LayouterBasics - Language.Haskell.Brittany.Internal.Backend - Language.Haskell.Brittany.Internal.BackendUtils Language.Haskell.Brittany.Internal.ExactPrintUtils - Language.Haskell.Brittany.Internal.Layouters.Type + Language.Haskell.Brittany.Internal.LayouterBasics + Language.Haskell.Brittany.Internal.Layouters.DataDecl Language.Haskell.Brittany.Internal.Layouters.Decl Language.Haskell.Brittany.Internal.Layouters.Expr - Language.Haskell.Brittany.Internal.Layouters.Stmt - Language.Haskell.Brittany.Internal.Layouters.Pattern Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Module - Language.Haskell.Brittany.Internal.Layouters.DataDecl + Language.Haskell.Brittany.Internal.Layouters.Pattern + Language.Haskell.Brittany.Internal.Layouters.Stmt + Language.Haskell.Brittany.Internal.Layouters.Type + Language.Haskell.Brittany.Internal.Obfuscation + Language.Haskell.Brittany.Internal.Prelude + Language.Haskell.Brittany.Internal.PreludeUtils Language.Haskell.Brittany.Internal.Transformations.Alt - Language.Haskell.Brittany.Internal.Transformations.Floating - Language.Haskell.Brittany.Internal.Transformations.Par Language.Haskell.Brittany.Internal.Transformations.Columns + Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Indent + Language.Haskell.Brittany.Internal.Transformations.Par + Language.Haskell.Brittany.Internal.Types + Language.Haskell.Brittany.Internal.Utils + Language.Haskell.Brittany.Main + Paths_brittany + autogen-modules: Paths_brittany executable brittany import: executable -- 2.30.2 From d03deccba88d5abc8c4ec328e142e10943e1a785 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 20:38:28 +0000 Subject: [PATCH 431/478] Remove unnecessary export lists --- src-brittany/Main.hs | 2 - src-libinterfacetests/Main.hs | 4 - src-literatetests/Main.hs | 7 -- src-unittests/AsymptoticPerfTests.hs | 5 +- src-unittests/TestMain.hs | 3 - .../Haskell/Brittany/Internal/Backend.hs | 5 +- .../Haskell/Brittany/Internal/BackendUtils.hs | 29 +------ .../Haskell/Brittany/Internal/Config.hs | 20 +---- .../Haskell/Brittany/Internal/Config/Types.hs | 6 +- .../Internal/Config/Types/Instances.hs | 3 +- .../Brittany/Internal/ExactPrintUtils.hs | 10 +-- .../Brittany/Internal/LayouterBasics.hs | 78 +------------------ .../Brittany/Internal/Layouters/DataDecl.hs | 5 +- .../Brittany/Internal/Layouters/Decl.hs | 12 +-- .../Brittany/Internal/Layouters/Expr.hs | 7 +- .../Brittany/Internal/Layouters/Expr.hs-boot | 7 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 8 +- .../Brittany/Internal/Layouters/Import.hs | 2 +- .../Brittany/Internal/Layouters/Module.hs | 2 +- .../Brittany/Internal/Layouters/Pattern.hs | 6 +- .../Brittany/Internal/Layouters/Stmt.hs | 5 +- .../Brittany/Internal/Layouters/Stmt.hs-boot | 5 +- .../Brittany/Internal/Layouters/Type.hs | 7 +- .../Haskell/Brittany/Internal/Obfuscation.hs | 5 +- .../Haskell/Brittany/Internal/Prelude.hs | 9 +-- .../Haskell/Brittany/Internal/PreludeUtils.hs | 3 +- .../Brittany/Internal/Transformations/Alt.hs | 5 +- .../Internal/Transformations/Columns.hs | 5 +- .../Internal/Transformations/Floating.hs | 5 +- .../Internal/Transformations/Indent.hs | 5 +- .../Brittany/Internal/Transformations/Par.hs | 5 +- .../Haskell/Brittany/Internal/Types.hs | 3 +- .../Haskell/Brittany/Internal/Utils.hs | 28 +------ src/Language/Haskell/Brittany/Main.hs | 2 +- 34 files changed, 30 insertions(+), 283 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 0312f6b..7a5ae94 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -1,5 +1,3 @@ -module Main where - import qualified Language.Haskell.Brittany.Main as BrittanyMain main :: IO () diff --git a/src-libinterfacetests/Main.hs b/src-libinterfacetests/Main.hs index f663174..2d1924f 100644 --- a/src-libinterfacetests/Main.hs +++ b/src-libinterfacetests/Main.hs @@ -1,7 +1,3 @@ -module Main where - - - import Test.Hspec import Language.Haskell.Brittany import qualified Data.Text as Text diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 399c08e..5949a55 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -2,13 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} -module Main - ( main - ) -where - - - import Language.Haskell.Brittany.Internal.Prelude import qualified Data.List.Extra import qualified Data.Maybe diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs index 6abbf90..702ab90 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -1,9 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} -module AsymptoticPerfTests - ( asymptoticPerfTest - ) -where +module AsymptoticPerfTests where diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs index 81ec429..2f0f894 100644 --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -1,6 +1,3 @@ -module Main where - - import Test.Hspec import AsymptoticPerfTests diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 204a16f..b8241bf 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -4,10 +4,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Backend - ( layoutBriDocM - ) -where +module Language.Haskell.Brittany.Internal.Backend where diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 444d548..8003fd8 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -1,34 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.BackendUtils - ( layoutWriteAppend - , layoutWriteAppendMultiline - , layoutWriteNewlineBlock - , layoutWriteNewline - , layoutWriteEnsureNewlineBlock - , layoutWriteEnsureBlock - , layoutWithAddBaseCol - , layoutWithAddBaseColBlock - , layoutWithAddBaseColN - , layoutWithAddBaseColNBlock - , layoutBaseYPushCur - , layoutBaseYPop - , layoutIndentLevelPushCur - , layoutIndentLevelPop - , layoutWriteEnsureAbsoluteN - , layoutAddSepSpace - , layoutSetCommentCol - , layoutMoveToCommentPos - , layoutIndentRestorePostComment - , moveToExactAnn - , moveToY - , ppmMoveToExactLoc - , layoutWritePriorComments - , layoutWritePostComments - , layoutRemoveIndentLevelLinger - ) -where +module Language.Haskell.Brittany.Internal.BackendUtils where import Language.Haskell.Brittany.Internal.Prelude diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index c243e20..66d6d7f 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -1,25 +1,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Config - ( CConfig(..) - , CDebugConfig(..) - , CLayoutConfig(..) - , DebugConfig - , LayoutConfig - , Config - , cmdlineConfigParser - , staticDefaultConfig - , forwardOptionsSyntaxExtsEnabled - , readConfig - , userConfigPath - , findLocalConfigPath - , readConfigs - , readConfigsWithUserConfig - , writeDefaultConfig - , showConfigYaml - ) -where +module Language.Haskell.Brittany.Internal.Config where diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 30d32c3..929ac90 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -5,11 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -module Language.Haskell.Brittany.Internal.Config.Types - ( module Language.Haskell.Brittany.Internal.Config.Types - , cMap - ) -where +module Language.Haskell.Brittany.Internal.Config.Types where diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 97484b4..2c0c78f 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -16,8 +16,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Config.Types.Instances -where +module Language.Haskell.Brittany.Internal.Config.Types.Instances where diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 4c281aa..f2c7806 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -5,15 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.ExactPrintUtils - ( parseModule - , parseModuleFromString - , commentAnnFixTransformGlob - , extractToplevelAnns - , foldedAnnKeys - , withTransformedAnns - ) -where +module Language.Haskell.Brittany.Internal.ExactPrintUtils where diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index e89549f..1d8f48a 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -4,83 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.LayouterBasics - ( processDefault - , rdrNameToText - , lrdrNameToText - , lrdrNameToTextAnn - , lrdrNameToTextAnnTypeEqualityIsSpecial - , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick - , askIndent - , extractAllComments - , extractRestComments - , filterAnns - , docEmpty - , docLit - , docLitS - , docAlt - , CollectAltM - , addAlternativeCond - , addAlternative - , runFilteredAlternative - , docLines - , docCols - , docSeq - , docPar - , docNodeAnnKW - , docNodeMoveToKWDP - , docWrapNode - , docWrapNodePrior - , docWrapNodeRest - , docForceSingleline - , docForceMultiline - , docEnsureIndent - , docAddBaseY - , docSetBaseY - , docSetIndentLevel - , docSeparator - , docAnnotationPrior - , docAnnotationKW - , docAnnotationRest - , docMoveToKWDP - , docNonBottomSpacing - , docNonBottomSpacingS - , docSetParSpacing - , docForceParSpacing - , docDebug - , docSetBaseAndIndent - , briDocByExact - , briDocByExactNoComment - , briDocByExactInlineOnly - , foldedAnnKeys - , unknownNodeError - , appSep - , docCommaSep - , docParenLSep - , docParenL - , docParenR - , docParenHashLSep - , docParenHashRSep - , docBracketL - , docBracketR - , docTick - , spacifyDocs - , briDocMToPPM - , briDocMToPPMInner - , allocateNode - , docSharedWrapper - , hasAnyCommentsBelow - , hasCommentsBetween - , hasAnyCommentsConnected - , hasAnyCommentsPrior - , hasAnyRegularCommentsConnected - , hasAnyRegularCommentsRest - , hasAnnKeywordComment - , hasAnnKeyword - , astAnn - , allocNodeIndex - ) -where +module Language.Haskell.Brittany.Internal.LayouterBasics where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 6a5af9b..49f615a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -1,10 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.DataDecl - ( layoutDataDecl - ) -where +module Language.Haskell.Brittany.Internal.Layouters.DataDecl where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index a9621f4..a2d4a00 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -3,17 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Layouters.Decl - ( layoutDecl - , layoutSig - , layoutBind - , layoutLocalBinds - , layoutGuardLStmt - , layoutPatternBind - , layoutGrhs - , layoutPatternBindFinal - ) -where +module Language.Haskell.Brittany.Internal.Layouters.Decl where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 564fe3f..b26687c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -2,12 +2,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Expr - ( layoutExpr - , litBriDoc - , overLitValBriDoc - ) -where +module Language.Haskell.Brittany.Internal.Layouters.Expr where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 5ee3716..8fb094b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -1,11 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Expr - ( layoutExpr - , litBriDoc - , overLitValBriDoc - ) -where +module Language.Haskell.Brittany.Internal.Layouters.Expr where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 481a030..06aa0cf 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -2,13 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.IE - ( layoutIE - , layoutLLIEs - , layoutAnnAndSepLLIEs - , SortItemsFlag(..) - ) -where +module Language.Haskell.Brittany.Internal.Layouters.IE where import Language.Haskell.Brittany.Internal.Prelude import qualified Data.List.Extra diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 2a1edf5..1b19145 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where +module Language.Haskell.Brittany.Internal.Layouters.Import where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 00c3bfd..52c2cd1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where +module Language.Haskell.Brittany.Internal.Layouters.Module where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 6ea00a1..4b99bca 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -1,11 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Pattern - ( layoutPat - , colsWrapPat - ) -where +module Language.Haskell.Brittany.Internal.Layouters.Pattern where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 73bc785..95f7273 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -2,10 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Layouters.Stmt - ( layoutStmt - ) -where +module Language.Haskell.Brittany.Internal.Layouters.Stmt where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 8b6c000..02b388c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -1,9 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Stmt - ( layoutStmt - ) -where +module Language.Haskell.Brittany.Internal.Layouters.Stmt where diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 63fa20a..f5efb7f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -1,12 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Type - ( layoutType - , layoutTyVarBndrs - , processTyVarBndrsSingleline - ) -where +module Language.Haskell.Brittany.Internal.Layouters.Type where diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs index 427fe43..29dc13c 100644 --- a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -1,9 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Obfuscation - ( obfuscate - ) -where +module Language.Haskell.Brittany.Internal.Obfuscation where diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index b6c4423..d09b788 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,8 +1,4 @@ -module Language.Haskell.Brittany.Internal.Prelude - ( module E - , module Language.Haskell.Brittany.Internal.Prelude - ) -where +module Language.Haskell.Brittany.Internal.Prelude ( module E ) where @@ -361,6 +357,3 @@ import Control.Monad.Trans.Maybe as E ( MaybeT (..) import Data.Data as E ( toConstr ) - -todo :: a -todo = error "todo" diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs index 445a0ab..cfaed43 100644 --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Haskell.Brittany.Internal.PreludeUtils -where +module Language.Haskell.Brittany.Internal.PreludeUtils where diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 4dfbba2..57461ca 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -7,10 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -module Language.Haskell.Brittany.Internal.Transformations.Alt - ( transformAlts - ) -where +module Language.Haskell.Brittany.Internal.Transformations.Alt where diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 732e6a1..89a2c6f 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -1,10 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Columns - ( transformSimplifyColumns - ) -where +module Language.Haskell.Brittany.Internal.Transformations.Columns where diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 87d551d..0231306 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -1,10 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Floating - ( transformSimplifyFloating - ) -where +module Language.Haskell.Brittany.Internal.Transformations.Floating where diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index e39790a..7f7d7e5 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -1,10 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Indent - ( transformSimplifyIndent - ) -where +module Language.Haskell.Brittany.Internal.Transformations.Indent where diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs index eb186f4..305ee08 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -1,10 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Par - ( transformSimplifyPar - ) -where +module Language.Haskell.Brittany.Internal.Transformations.Par where diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index db9e36d..55c3746 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -11,8 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -module Language.Haskell.Brittany.Internal.Types -where +module Language.Haskell.Brittany.Internal.Types where diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index a18f874..a12f7ea 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -5,33 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Utils - ( parDoc - , parDocW - , fromMaybeIdentity - , fromOptionIdentity - , traceIfDumpConf - , mModify - , customLayouterF - , astToDoc - , briDocToDoc - -- , displayBriDocSimpleTree - , annsDoc - , Max (..) - , tellDebugMess - , tellDebugMessShow - , briDocToDocWithAnns - , breakEither - , spanMaybe - , transformUp - , transformDownMay - , FirstLastView(..) - , splitFirstLast - , lines' - , showOutputable - , absurdExt - ) -where +module Language.Haskell.Brittany.Internal.Utils where diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs index e1d482b..7df86d5 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ b/src/Language/Haskell/Brittany/Main.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Main (main) where +module Language.Haskell.Brittany.Main where -- 2.30.2 From 75cf5b83a3c24309ef4fe4171d8de8b3aeb381ab Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 20:40:31 +0000 Subject: [PATCH 432/478] Remove unused tests --- src-idemtests/.gitignore | 4 - src-idemtests/README | 17 - src-idemtests/brittany.yaml | 29 -- src-idemtests/cases/LayoutBasics.hs | 733 ---------------------------- src-idemtests/run.sh | 36 -- 5 files changed, 819 deletions(-) delete mode 100644 src-idemtests/.gitignore delete mode 100644 src-idemtests/README delete mode 100644 src-idemtests/brittany.yaml delete mode 100644 src-idemtests/cases/LayoutBasics.hs delete mode 100755 src-idemtests/run.sh diff --git a/src-idemtests/.gitignore b/src-idemtests/.gitignore deleted file mode 100644 index 4830bd8..0000000 --- a/src-idemtests/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -iterOne/ -iterTwo/ -brittany -report.txt diff --git a/src-idemtests/README b/src-idemtests/README deleted file mode 100644 index 3560f17..0000000 --- a/src-idemtests/README +++ /dev/null @@ -1,17 +0,0 @@ -idempotency testing on real-life examples, i.e. checks that brittany(x) is -equal to brittany(brittany(x)) for some x's. The idea is that these testcases -are not yet transformed, i.e. that x is not brittany(x). This can capture -certain bugs that are not detected by checking that brittany behaves as -identity on "well-formed" input. - -to run: - -- put a "brittany" executable into this directory. -- cd into this directory. -- ./run.sh - -report.txt will contain the results. - -note that only the configuration in brittany.yaml is tested, which contains -the default settings. ideally this would be managed in some other, more -transparent fashion. diff --git a/src-idemtests/brittany.yaml b/src-idemtests/brittany.yaml deleted file mode 100644 index 6e5dcfb..0000000 --- a/src-idemtests/brittany.yaml +++ /dev/null @@ -1,29 +0,0 @@ -conf_errorHandling: - econf_Werror: false - econf_produceOutputOnErrors: false - econf_CPPMode: CPPModeNowarn -conf_layout: - lconfig_indentPolicy: IndentPolicyFree - lconfig_cols: 80 - lconfig_indentAmount: 2 - lconfig_importColumn: 60 - lconfig_altChooser: - tag: AltChooserBoundedSearch - contents: 3 - lconfig_indentWhereSpecial: true - lconfig_indentListSpecial: true -conf_forward: - options_ghc: [] -conf_debug: - dconf_dump_annotations: false - dconf_dump_bridoc_simpl_par: false - dconf_dump_bridoc_simpl_indent: false - dconf_dump_bridoc_simpl_floating: false - dconf_dump_ast_full: false - dconf_dump_bridoc_simpl_columns: false - dconf_dump_ast_unknown: false - dconf_dump_bridoc_simpl_alt: false - dconf_dump_bridoc_final: false - dconf_dump_bridoc_raw: false - dconf_dump_config: false - diff --git a/src-idemtests/cases/LayoutBasics.hs b/src-idemtests/cases/LayoutBasics.hs deleted file mode 100644 index d1331a5..0000000 --- a/src-idemtests/cases/LayoutBasics.hs +++ /dev/null @@ -1,733 +0,0 @@ -module Language.Haskell.Brittany.Internal.LayoutBasics - ( processDefault - , layoutByExact - -- , layoutByExactR - , descToBlockStart - , descToBlockMinMax - , descToMinMax - , rdrNameToText - , lrdrNameToText - , lrdrNameToTextAnn - , askIndent - , calcLayoutMin - , calcLayoutMax - , getCurRemaining - , layoutWriteAppend - , layoutWriteAppendMultiline - , layoutWriteNewline - , layoutWriteNewlinePlain - , layoutWriteEnsureNewline - , layoutWriteEnsureBlock - , layoutWriteEnsureBlockPlusN - , layoutWithAddIndent - , layoutWithAddIndentBlock - , layoutWithAddIndentN - , layoutWithAddIndentNBlock - , layoutWithNonParamIndent - , layoutWriteEnsureAbsoluteN - , layoutAddSepSpace - , moveToExactAnn - , moveToExactAnn' - , setOpIndent - , stringLayouter - , layoutWritePriorComments - , layoutWritePostComments - , layoutIndentRestorePostComment - , layoutWritePriorCommentsRestore - , layoutWritePostCommentsRestore - , extractCommentsPrior - , extractCommentsPost - , applyLayouter - , applyLayouterRestore - , filterAnns - , layouterFToLayouterM - , ppmMoveToExactLoc - , customLayouterF - , docEmpty - , docLit - , docAlt - , docSeq - , docPar - -- , docCols - , docPostComment - , docWrapNode - , briDocByExact - , fromMaybeIdentity - , foldedAnnKeys - ) -where - - - --- more imports here.. - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - -import RdrName ( RdrName(..) ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified Outputable as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified SrcLoc as GHC -import SrcLoc ( SrcSpan ) -import OccName ( occNameString ) -import Name ( getOccString ) -import Module ( moduleName ) -import ApiAnnotation ( AnnKeywordId(..) ) - -import Data.Data -import Data.Generics.Schemes -import Data.Generics.Aliases - -import DataTreePrint - -import qualified Text.PrettyPrint as PP - -import Data.Function ( fix ) - - - -processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter - Text.Builder.Builder m, - MonadMultiReader ExactPrint.Types.Anns m) - => GenLocated SrcSpan ast - -> m () -processDefault x = do - anns <- mAsk - let str = ExactPrint.exactPrint x anns - -- this hack is here so our print-empty-module trick does not add - -- a newline at the start if there actually is no module header / imports - -- / anything. - -- TODO: instead the appropriate annotation could be removed when "cleaning" - -- the module (header). This would remove the need for this hack! - --test - case str of - "\n" -> return () - _ -> mTell $ Text.Builder.fromString $ str - - -layoutByExact :: ( MonadMultiReader Config m - , MonadMultiReader (ExactPrint.Types.Anns) m - , ExactPrint.Annotate.Annotate ast - ) - => GenLocated SrcSpan ast -> m Layouter -layoutByExact x = do - anns <- mAsk - trace (showTreeWithCustom (customLayouterF anns) x) $ layoutByExactR x - -- trace (ExactPrint.Utils.showAnnData anns 2 x) $ layoutByExactR x - -layoutByExactR :: (MonadMultiReader Config m - , MonadMultiReader (ExactPrint.Types.Anns) m - , ExactPrint.Annotate.Annotate ast) - => GenLocated SrcSpan ast -> m Layouter -layoutByExactR x = do - indent <- askIndent - anns <- mAsk - let t = Text.pack $ ExactPrint.exactPrint x anns - let tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines - let len = indent + maximum (Text.length <$> tlines) - return $ Layouter - { _layouter_desc = LayoutDesc Nothing $ Just $ BlockDesc AllSameIndent len len Nothing - , _layouter_func = \_ -> do - -- layoutWriteEnsureBlock - layoutWriteAppend $ Text.pack $ "{-" ++ show (ExactPrint.Types.mkAnnKey x, Map.lookup (ExactPrint.Types.mkAnnKey x) anns) ++ "-}" - zip [1..] tlines `forM_` \(i, l) -> do - layoutWriteAppend $ l - unless (i==tlineCount) layoutWriteNewline - do - let subKeys = foldedAnnKeys x - state <- mGet - let filterF k _ = not $ k `Set.member` subKeys - mSet $ state - { _lstate_commentsPrior = Map.filterWithKey filterF - $ _lstate_commentsPrior state - , _lstate_commentsPost = Map.filterWithKey filterF - $ _lstate_commentsPost state - } - , _layouter_ast = x - } - -briDocByExact :: (ExactPrint.Annotate.Annotate ast, - MonadMultiReader Config m, - MonadMultiReader ExactPrint.Types.Anns m - ) => GenLocated SrcSpan ast -> m BriDoc -briDocByExact ast = do - anns <- mAsk - traceIfDumpConf "ast" _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - return $ docExt ast anns - -descToBlockStart :: LayoutDesc -> Maybe BlockStart -descToBlockStart (LayoutDesc _ (Just (BlockDesc bs _ _ _))) = Just bs -descToBlockStart (LayoutDesc (Just line) _) = Just $ RestOfLine line -descToBlockStart _ = Nothing - -descToBlockMinMax :: LayoutDesc -> Maybe (Int, Int) -descToBlockMinMax (LayoutDesc _ (Just (BlockDesc _ bmin bmax _))) = Just (bmin, bmax) -descToBlockMinMax _ = Nothing - -descToMinMax :: Int -> LayoutDesc -> Maybe (Int, Int) -descToMinMax p (LayoutDesc _ (Just (BlockDesc start bmin bmax _))) = - Just (max rolMin bmin, max rolMin bmax) - where - rolMin = case start of - RestOfLine rol -> p + _lColumns_min rol - AllSameIndent -> 0 - -descToMinMax p (LayoutDesc (Just (LayoutColumns _ _ lmin)) _) = - Just (len, len) - where - len = p + lmin -descToMinMax _ _ = - Nothing - -rdrNameToText :: RdrName -> Text --- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr -rdrNameToText ( Unqual occname ) = Text.pack $ occNameString occname -rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname - ++ "." - ++ occNameString occname -rdrNameToText ( Orig modul occname ) = Text.pack $ moduleNameString (moduleName modul) - ++ occNameString occname -rdrNameToText ( Exact name ) = Text.pack $ getOccString name - -lrdrNameToText :: GenLocated l RdrName -> Text -lrdrNameToText (L _ n) = rdrNameToText n - -lrdrNameToTextAnn :: ( MonadMultiReader Config m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => GenLocated SrcSpan RdrName - -> m Text -lrdrNameToTextAnn ast@(L _ n) = do - anns <- mAsk - let t = rdrNameToText n - let hasUni x (ExactPrint.Types.G y, _) = x==y - hasUni _ _ = False - -- TODO: in general: we should _always_ process all annotaiton stuff here. - -- whatever we don't probably should have had some effect on the - -- output. in such cases, resorting to byExact is probably the safe - -- choice. - return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> traceShow "Nothing" t - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> if - | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" - | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - | otherwise -> t - - -askIndent :: (MonadMultiReader Config m) => m Int -askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk - --- minimum block width, judged from block info or line, whichever is --- available. --- example: calcLayoutMin doBlock ~~~ atomically $ do --- foo --- ## indent --- ############# linepre --- ############### result (in this case) -calcLayoutMin :: Int -- basic indentation amount - -> Int -- currently used width in current line (after indent) - -- used to accurately calc placing of the current-line - -- stuff ("do" in the above example) and its width. - -> LayoutDesc - -> Int -calcLayoutMin indent linePre (LayoutDesc line block) = case (line, block) of - (_, Just (BlockDesc AllSameIndent m _ _)) -> indent + m - (_, Just (BlockDesc (RestOfLine inl) m _ _)) -> max (linePre + _lColumns_min inl) (indent + m) - (Just s, _) -> indent + _lColumns_min s - _ -> error "bad LayoutDesc mnasdoiucxvlkjasd" - --- see -calcLayoutMax :: Int -- basic indentation amount - -> Int -- currently used width in current line (after indent) - -- used to accurately calc placing of the current-line - -- stuff ("do" in the above example) and its width. - -> LayoutDesc - -> Int -calcLayoutMax indent linePre (LayoutDesc line block) = case (line, block) of - (Just s, _) -> linePre + _lColumns_min s - (_, Just (BlockDesc AllSameIndent _ m _)) -> indent + m - (_, Just (BlockDesc (RestOfLine inl) _ m _)) -> max (linePre + _lColumns_min inl) (indent + m) - _ -> error "bad LayoutDesc msdnfgouvadnfoiu" - -getCurRemaining :: ( MonadMultiReader Config m - , MonadMultiState LayoutState m - ) - => m Int -getCurRemaining = do - cols <- mAsk <&> _conf_layout .> _lconfig_cols .> runIdentity - clc <- _lstate_curLineCols <$> mGet - return $ cols - clc - -layoutWriteAppend :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Text - -> m () -layoutWriteAppend t = do - state <- mGet - if _lstate_addSepSpace state - then do - mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t + 1 - , _lstate_addSepSpace = False - } - mTell $ Text.Builder.fromText $ Text.pack " " <> t - else do - mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t } - mTell $ Text.Builder.fromText t - -layoutWriteAppendMultiline :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Text - -> m () -layoutWriteAppendMultiline t = case Text.lines t of - [] -> return () - (l:lr) -> do - layoutWriteAppend l - lr `forM_` \x -> do - layoutWriteNewlinePlain - layoutWriteAppend x - --- adds a newline and adds spaces to reach the current indentation level. --- TODO: rename newline -> newlineBlock and newlinePlain -> newline -layoutWriteNewline :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => m () -layoutWriteNewline = do - state <- mGet - mSet $ state { _lstate_curLineCols = _lstate_indent state - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = False - } - mTell $ Text.Builder.fromString $ "\n" ++ replicate (_lstate_indent state) ' ' - --- | does _not_ add spaces to again reach the current indentation levels. -layoutWriteNewlinePlain :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => m () -layoutWriteNewlinePlain = do - state <- mGet - mSet $ state { _lstate_curLineCols = 0 - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = False - } - mTell $ Text.Builder.fromString $ "\n" - -layoutWriteEnsureNewline :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => m () -layoutWriteEnsureNewline = do - state <- mGet - when (_lstate_curLineCols state /= _lstate_indent state) - $ layoutWriteNewline - -layoutWriteEnsureBlock :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => m () -layoutWriteEnsureBlock = do - state <- mGet - let diff = _lstate_curLineCols state - _lstate_indent state - if diff>0 - then layoutWriteNewline - else if diff<0 - then do - layoutWriteAppend $ Text.pack $ replicate (negate diff) ' ' - mSet $ state { _lstate_curLineCols = _lstate_indent state - , _lstate_addSepSpace = False - } - else return () - -layoutWriteEnsureAbsoluteN :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Int -> m () -layoutWriteEnsureAbsoluteN n = do - state <- mGet - let diff = n - _lstate_curLineCols state - if diff>0 - then do - layoutWriteAppend $ Text.pack $ replicate diff ' ' - mSet $ state { _lstate_curLineCols = n - , _lstate_addSepSpace = False - } - else return () - -layoutWriteEnsureBlockPlusN :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Int -> m () -layoutWriteEnsureBlockPlusN n = do - state <- mGet - let diff = _lstate_curLineCols state - _lstate_indent state - n - if diff>0 - then layoutWriteNewline - else if diff<0 - then do - layoutWriteAppend $ Text.pack $ replicate (negate diff) ' ' - mSet $ state { _lstate_addSepSpace = False } - else return () - -layoutWithAddIndent :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - ,MonadMultiReader Config m) - => m () - -> m () -layoutWithAddIndent m = do - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity - state <- mGet - mSet state { _lstate_indent = _lstate_indent state + amount } - m - do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -layoutWithAddIndentBlock :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - ,MonadMultiReader Config m) - => m () - -> m () -layoutWithAddIndentBlock m = do - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity - state <- mGet - mSet state { _lstate_indent = _lstate_indent state + amount } - layoutWriteEnsureBlock - m - do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -layoutWithAddIndentNBlock :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Int - -> m () - -> m () -layoutWithAddIndentNBlock amount m = do - state <- mGet - mSet state { _lstate_indent = _lstate_indent state + amount } - layoutWriteEnsureBlock - m - do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -layoutWithAddIndentN :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Int - -> m () - -> m () -layoutWithAddIndentN amount m = do - state <- mGet - mSet state { _lstate_indent = _lstate_indent state + amount } - m - do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -layoutAddSepSpace :: MonadMultiState LayoutState m => m () -layoutAddSepSpace = do - state <- mGet - mSet $ state { _lstate_addSepSpace = True } - -moveToExactAnn :: (Data.Data.Data x, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m, - MonadMultiReader (Map AnnKey Annotation) m) => GenLocated SrcSpan x -> m () -moveToExactAnn ast = do - anns <- mAsk - case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> return () - Just ann -> do - let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann - replicateM_ x $ layoutWriteNewline - --- TODO: when refactoring is complete, the other version of this method --- can probably be removed. -moveToExactAnn' :: (MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m, - MonadMultiReader (Map AnnKey Annotation) m) => AnnKey -> m () -moveToExactAnn' annKey = do - anns <- mAsk - case Map.lookup annKey anns of - Nothing -> return () - Just ann -> do - -- curY <- mGet <&> _lstate_curLineCols - let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann - replicateM_ x $ layoutWriteNewline - -- when (x/=0) $ do - -- replicateM_ x $ layoutWriteNewlinePlain - -- mModify $ \s -> s { _lstate_curLineCols = curY } - -- mTell $ Text.Builder.fromString $ replicate curY ' ' - -ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m - => ExactPrint.Types.DeltaPos - -> m () -ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do - replicateM_ x $ mTell $ Text.Builder.fromString "\n" - replicateM_ y $ mTell $ Text.Builder.fromString " " - -layoutWithNonParamIndent :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m) - => LayoutFuncParams -> m () -> m () -layoutWithNonParamIndent params m = do - case _params_opIndent params of - Nothing -> m - Just x -> layoutWithAddIndentN x m - -setOpIndent :: Int -> LayoutDesc -> LayoutFuncParams -> LayoutFuncParams -setOpIndent i desc p = p - { _params_opIndent = Just $ case _bdesc_opIndentFloatUp =<< _ldesc_block desc of - Nothing -> i - Just j -> max i j - } - -stringLayouter :: Data.Data.Data ast - => GenLocated SrcSpan ast -> Text -> Layouter -stringLayouter ast t = Layouter - { _layouter_desc = LayoutDesc - { _ldesc_line = Just $ LayoutColumns - { _lColumns_key = ColumnKeyUnique - , _lColumns_lengths = [Text.length t] - , _lColumns_min = Text.length t - } - , _ldesc_block = Nothing - } - , _layouter_func = \_ -> do - layoutWritePriorCommentsRestore ast - layoutWriteAppend t - layoutWritePostComments ast - , _layouter_ast = ast - } - -layoutWritePriorComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => GenLocated SrcSpan ast -> m () -layoutWritePriorComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.Types.mkAnnKey ast - let m = _lstate_commentsPrior state - let mAnn = Map.lookup key m - mSet $ state { _lstate_commentsPrior = Map.delete key m } - return mAnn - case mAnn of - Nothing -> return () - Just priors -> do - when (not $ null priors) $ do - state <- mGet - mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state } - priors `forM_` \( ExactPrint.Types.Comment comment _ _ - , ExactPrint.Types.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewlinePlain - layoutWriteAppend $ Text.pack $ replicate y ' ' - layoutWriteAppendMultiline $ Text.pack $ comment - --- this currently only extracs from the `annsDP` field of Annotations. --- per documentation, this seems sufficient, as the --- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => GenLocated SrcSpan ast -> m () -layoutWritePostComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.Types.mkAnnKey ast - let m = _lstate_commentsPost state - let mAnn = Map.lookup key m - mSet $ state { _lstate_commentsPost = Map.delete key m } - return mAnn - case mAnn of - Nothing -> return () - Just posts -> do - when (not $ null posts) $ do - state <- mGet - mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state } - posts `forM_` \( ExactPrint.Types.Comment comment _ _ - , ExactPrint.Types.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewlinePlain - layoutWriteAppend $ Text.pack $ replicate y ' ' - layoutWriteAppendMultiline $ Text.pack $ comment - -layoutIndentRestorePostComment :: ( Monad m - , MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - ) - => m () -layoutIndentRestorePostComment = do - mCommentCol <- _lstate_commentCol <$> mGet - case mCommentCol of - Nothing -> return () - Just commentCol -> do - layoutWriteNewlinePlain - layoutWriteAppend $ Text.pack $ replicate commentCol ' ' - -layoutWritePriorCommentsRestore :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => GenLocated SrcSpan ast -> m () -layoutWritePriorCommentsRestore x = do - layoutWritePriorComments x - layoutIndentRestorePostComment - -layoutWritePostCommentsRestore :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => GenLocated SrcSpan ast -> m () -layoutWritePostCommentsRestore x = do - layoutWritePostComments x - layoutIndentRestorePostComment - -extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap -extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann -> - [r | let r = ExactPrint.Types.annPriorComments ann, not (null r)] -extractCommentsPost :: ExactPrint.Types.Anns -> PostMap -extractCommentsPost anns = flip Map.mapMaybe anns $ \ann -> - [r - | let - r = ExactPrint.Types.annsDP ann - >>= \case - (ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)] - _ -> [] - , not (null r) - ] - - -applyLayouter :: Layouter -> LayoutFuncParams -> LayoutM () -applyLayouter l@(Layouter _ _ ast) params = do - -- (always) write the prior comments at this point. - layoutWritePriorCommentsRestore ast - -- run the real stuff. - _layouter_func l params - -- if the _layouter_func has not done so already at some point - -- (there are nodes for which this makes sense), - -- write the post comments. - -- effect is `return ()` if there are no postComments. - layoutWritePostComments ast - -applyLayouterRestore :: Layouter -> LayoutFuncParams -> LayoutM () -applyLayouterRestore l@(Layouter _ _ ast) params = do - -- (always) write the prior comments at this point. - layoutWritePriorCommentsRestore ast - -- run the real stuff. - _layouter_func l params - -- if the _layouter_func has not done so already at some point - -- (there are nodes for which this makes sense), - -- write the post comments. - -- effect is `return ()` if there are no postComments. - layoutWritePostCommentsRestore ast - -foldedAnnKeys :: Data.Data.Data ast - => ast - -> Set ExactPrint.Types.AnnKey -foldedAnnKeys ast = everything - Set.union - (\x -> maybe - Set.empty - Set.singleton - [ gmapQi 1 (\t -> ExactPrint.Types.mkAnnKey $ L l t) x - | typeRepTyCon (typeOf (L () ())) == (typeRepTyCon (typeOf x)) - , l <- gmapQi 0 cast x - ] - ) - ast - -filterAnns :: Data.Data.Data ast - => ast - -> ExactPrint.Types.Anns - -> ExactPrint.Types.Anns -filterAnns ast anns = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns - -layouterFToLayouterM :: MultiReader '[Config, ExactPrint.Types.Anns] a -> LayoutM a -layouterFToLayouterM m = do - settings <- mAsk - anns <- mAsk - return $ runIdentity - $ runMultiReaderTNil - $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader anns - $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader settings - $ m - --- new BriDoc stuff - -docEmpty :: BriDoc -docEmpty = BDEmpty - -docLit :: Text -> BriDoc -docLit t = BDLit t - -docExt :: ExactPrint.Annotate.Annotate ast - => GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> BriDoc -docExt x anns = BDExternal - (ExactPrint.Types.mkAnnKey x) - (foldedAnnKeys x) - (Text.pack $ ExactPrint.exactPrint x anns) - -docAlt :: [BriDoc] -> BriDoc -docAlt = BDAlt - - -docSeq :: [BriDoc] -> BriDoc -docSeq = BDSeq - - -docPostComment :: Data.Data.Data ast - => GenLocated SrcSpan ast - -> BriDoc - -> BriDoc -docPostComment ast bd = BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd - -docWrapNode :: Data.Data.Data ast - => GenLocated SrcSpan ast - -> BriDoc - -> BriDoc -docWrapNode ast bd = BDAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) - $ bd - -docPar :: BriDoc - -> BriDoc - -> BriDoc -docPar line indented = BDPar BrIndentNone line indented - --- docPar :: BriDoc --- -> BrIndent --- -> [BriDoc] --- -> BriDoc --- docPar = BDPar - --- docCols :: ColSig --- -> [BriDoc] --- -> BriDoc --- docCols = BDCols - - -fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = Data.Coerce.coerce - $ fromMaybe (Data.Coerce.coerce x) y diff --git a/src-idemtests/run.sh b/src-idemtests/run.sh deleted file mode 100755 index 298ecef..0000000 --- a/src-idemtests/run.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/bash - -# set -x -set -e - -rm report.txt &> /dev/null || true - -mkdir iterOne &> /dev/null || true -mkdir iterTwo &> /dev/null || true - -for FILE in ./cases/* -do - NAME=$(basename "$FILE") - ITERNAMEONE="./iterOne/$NAME" - ITERNAMETWO="./iterTwo/$NAME" - if ! ./brittany -i "$FILE" -o "$ITERNAMEONE" - then - echo "FAILED step 1 for $FILE" | tee -a report.txt - continue - fi - if ! ./brittany -i "$ITERNAMEONE" -o "$ITERNAMETWO" - then - echo "FAILED step 2 for $FILE" | tee -a report.txt - continue - fi - if ! diff "$ITERNAMEONE" "$ITERNAMETWO" > diff.temp - then - echo "FAILED diff for $FILE with diff:" | tee -a report.txt - cat diff.temp | tee -a report.txt - echo "# meld $(realpath $ITERNAMEONE) $(realpath $ITERNAMETWO)" | tee -a report.txt - continue - fi - echo "success for $FILE" | tee -a report.txt -done - -rm diff.temp &> /dev/null || true -- 2.30.2 From 392e5b7569f692f1cb98980b29aadaee0338c6c9 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:05:10 +0000 Subject: [PATCH 433/478] Fix many HLint warnings --- .hlint.yaml | 50 +------ src-literatetests/Main.hs | 4 +- src/Language/Haskell/Brittany/Internal.hs | 18 +-- .../Haskell/Brittany/Internal/Backend.hs | 31 ++-- .../Haskell/Brittany/Internal/BackendUtils.hs | 8 +- .../Brittany/Internal/ExactPrintUtils.hs | 18 +-- .../Brittany/Internal/LayouterBasics.hs | 3 +- .../Brittany/Internal/Layouters/DataDecl.hs | 10 +- .../Brittany/Internal/Layouters/Decl.hs | 8 +- .../Brittany/Internal/Layouters/Expr.hs | 2 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 8 +- .../Brittany/Internal/Layouters/Type.hs | 2 +- .../Haskell/Brittany/Internal/Prelude.hs | 137 ++++++++---------- .../Brittany/Internal/Transformations/Alt.hs | 12 +- .../Haskell/Brittany/Internal/Types.hs | 7 +- src/Language/Haskell/Brittany/Main.hs | 16 +- 16 files changed, 134 insertions(+), 200 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 026d8f1..191512f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -5,56 +5,12 @@ # This file contains a template configuration file, which is typically # placed as .hlint.yaml in the root of your project -# Specify additional command line arguments - -- arguments: - [ "--cross" - , "--threads=0" - ] - -- ignore: {name: "Use camelCase"} -- ignore: {name: "Redundant as"} -- ignore: {name: "Redundant do"} -- ignore: {name: "Redundant return"} -- ignore: {name: "Redundant guard", whithin: "lrdrNameToTextAnn"} - - ignore: { name: 'Use :' } -- ignore: { name: Avoid lambda } - ignore: { name: Eta reduce } - ignore: { name: Move brackets to avoid $ } -- ignore: { name: Redundant <$> } - ignore: { name: Redundant $ } -- ignore: { name: Redundant bang pattern } - ignore: { name: Redundant bracket } -- ignore: { name: Redundant flip } -- ignore: { name: Redundant id } -- ignore: { name: Redundant if } -- ignore: { name: Redundant lambda } -- ignore: { name: Replace case with fromMaybe } -- ignore: { name: Use <=< } -- ignore: { name: Use <$> } -- ignore: { name: Use all } -- ignore: { name: Use and } -- ignore: { name: Use any } -- ignore: { name: Use concatMap } -- ignore: { name: Use const } -- ignore: { name: Use elem } -- ignore: { name: Use elemIndex } -- ignore: { name: Use fewer imports } -- ignore: { name: Use first } -- ignore: { name: Use fromLeft } -- ignore: { name: Use getContents } -- ignore: { name: Use if } -- ignore: { name: Use isNothing } -- ignore: { name: Use lambda-case } -- ignore: { name: Use mapM } -- ignore: { name: Use minimumBy } - ignore: { name: Use newtype instead of data } -- ignore: { name: Use record patterns } -- ignore: { name: Use second } -- ignore: { name: Use section } -- ignore: { name: Use sortOn } -- ignore: { name: Use sqrt } -- ignore: { name: Use tuple-section } -- ignore: { name: Use unless } -- ignore: { name: Use when } +- ignore: {name: "Redundant do"} +- ignore: {name: "Redundant return"} +- ignore: {name: "Use camelCase"} diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 5949a55..a1dc2af 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -94,8 +94,8 @@ main = do fmap groupProcessor $ groupBy grouperG $ filter (not . lineIsSpace) - $ fmap lineMapper - $ Text.lines input + $ lineMapper + <$> Text.lines input where groupProcessor :: [InputLine] -> (Text, [TestCase]) groupProcessor = \case diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 41ac6b1..71e885b 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -60,7 +60,7 @@ import Language.Haskell.Brittany.Internal.Transformations.Par import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC +import qualified GHC hiding ( parseModule ) import GHC.Parser.Annotation ( AnnKeywordId(..) ) import GHC ( GenLocated(L) @@ -130,7 +130,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do , \s -> "{" `isPrefixOf` dropWhile (== ' ') s , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) - . either (\_ -> Nothing) Just + . either (const Nothing) Just . Data.Yaml.decodeEither' . Data.ByteString.Char8.pack -- TODO: use some proper utf8 encoder instead? @@ -299,7 +299,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do pure $ if hackAroundIncludes then ( ews - , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn + , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn (TextL.pack "\n") outRaw ) @@ -311,11 +311,9 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorMacroConfig{} = 5 let hasErrors = - case - moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack - of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL @@ -402,7 +400,7 @@ parsePrintModuleTests conf filename input = do then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule - if null $ filter (not . isErrorUnusedComment) errs + if all isErrorUnusedComment errs then pure $ TextL.toStrict $ ltext else let @@ -533,7 +531,7 @@ getDeclBindingNames (L _ decl) = case decl of ppPreamble :: GenLocated SrcSpan HsModule -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _ _)) = do +ppPreamble lmod@(L loc m@HsModule{}) = do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index b8241bf..142fe2f 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -11,10 +11,12 @@ module Language.Haskell.Brittany.Internal.Backend where import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.State.Strict as StateS +import qualified Data.Either as Either import qualified Data.Foldable as Foldable import qualified Data.IntMap.Lazy as IntMapL import qualified Data.IntMap.Strict as IntMapS import qualified Data.Map as Map +import qualified Data.Maybe as Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set @@ -171,7 +173,7 @@ layoutBriDocM = \case -- layoutResetSepSpace priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (not $ comment == "(" || comment == ")") $ do + when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment case comment of ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) @@ -191,7 +193,7 @@ layoutBriDocM = \case let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mToSpan = case mAnn of - Just anns | keyword == Nothing -> Just anns + Just anns | Maybe.isNothing keyword -> Just anns Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just annR _ -> Nothing @@ -212,7 +214,7 @@ layoutBriDocM = \case Nothing -> pure () Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (not $ comment == "(" || comment == ")") $ do + when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment -- evil hack for CPP: case comment of @@ -229,7 +231,7 @@ layoutBriDocM = \case state <- mGet let m = _lstate_comments state pure $ Map.lookup annKey m - let mComments = nonEmpty =<< extractAllComments <$> annMay + let mComments = nonEmpty . extractAllComments =<< annMay let semiCount = length [ () | Just ann <- [ annMay ] , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann @@ -252,10 +254,10 @@ layoutBriDocM = \case case mComments of Nothing -> do when shouldAddSemicolonNewlines $ do - [1..semiCount] `forM_` \_ -> layoutWriteNewline + [1..semiCount] `forM_` const layoutWriteNewline Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (not $ comment == "(" || comment == ")") $ do + when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack comment case comment of ('#':_) -> layoutMoveToCommentPos y (-999) 1 @@ -351,13 +353,13 @@ briDocIsMultiLine briDoc = rec briDoc BDBaseYPop bd -> rec bd BDIndentLevelPushCur bd -> rec bd BDIndentLevelPop bd -> rec bd - BDPar _ _ _ -> True + BDPar{} -> True BDAlt{} -> error "briDocIsMultiLine BDAlt" BDForceMultiline _ -> True BDForceSingleline bd -> rec bd BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal _ _ _ _ -> True + BDExternal{} -> True BDPlain t | [_] <- Text.lines t -> False BDPlain _ -> True BDAnnotationPrior _ bd -> rec bd @@ -453,7 +455,7 @@ 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 + return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe 0 (_lstate_addSepSpace state) colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack @@ -543,8 +545,8 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- 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 + shouldBreakAfter bd = alignBreak && + briDocIsMultiLine bd && case bd of (BDCols ColTyOpPrefix _) -> False (BDCols ColPatternsFuncPrefix _) -> True (BDCols ColPatternsFuncInfix _) -> True @@ -565,7 +567,6 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do (BDCols ColTuples _) -> False (BDCols ColOpPrefix _) -> False _ -> True - else False mergeInfoBriDoc :: Bool @@ -644,9 +645,7 @@ processInfo maxSpace m = \case curX <- do state <- mGet -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) - let spaceAdd = case _lstate_addSepSpace state of - Nothing -> 0 - Just i -> i + let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state return $ case _lstate_curYOrAddNewline state of Left i -> case _lstate_commentCol state of Nothing -> spaceAdd + i @@ -655,7 +654,7 @@ processInfo maxSpace m = \case let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let maxCols2 = list <&> \e -> case e of + let maxCols2 = list <&> \case (_, ColInfo i _ _) -> let Just (_, ms, _) = IntMapS.lookup i m in sum ms (l, _) -> l diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 8003fd8..6c34ea9 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -49,9 +49,7 @@ layoutWriteAppend t = do replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" Left{} -> do return () - let spaces = case _lstate_addSepSpace state of - Just i -> i - Nothing -> 0 + let spaces = fromMaybe 0 $ _lstate_addSepSpace state mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') mTell $ Text.Builder.fromText $ t mModify $ \s -> s @@ -452,7 +450,7 @@ layoutWritePriorComments ast = do case mAnn of Nothing -> return () Just priors -> do - when (not $ null priors) $ layoutSetCommentCol + unless (null priors) $ layoutSetCommentCol priors `forM_` \( ExactPrint.Comment comment _ _ , ExactPrint.DP (x, y) ) -> do @@ -484,7 +482,7 @@ layoutWritePostComments ast = do case mAnn of Nothing -> return () Just posts -> do - when (not $ null posts) $ layoutSetCommentCol + unless (null posts) $ layoutSetCommentCol posts `forM_` \( ExactPrint.Comment comment _ _ , ExactPrint.DP (x, y) ) -> do diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index f2c7806..46e1b6a 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -27,7 +27,7 @@ import Data.HList.HList import GHC ( GenLocated(L) ) import qualified GHC.Driver.Session as GHC -import qualified GHC as GHC hiding (parseModule) +import qualified GHC hiding (parseModule) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Driver.CmdLine as GHC @@ -78,11 +78,11 @@ parseModuleWithCpp cpp opts args fp dynCheck = -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063. void $ lift $ GHC.setSessionDynFlags dflags1 dflags2 <- lift $ ExactPrint.initDynFlags fp - when (not $ null leftover) + unless (null leftover) $ ExceptT.throwE $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) - when (not $ null warnings) + unless (null warnings) $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) @@ -110,11 +110,11 @@ parseModuleFromString args fp dynCheck str = dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) - when (not $ null leftover) + unless (null leftover) $ ExceptT.throwE $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) - when (not $ null warnings) + unless (null warnings) $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) @@ -135,7 +135,7 @@ commentAnnFixTransformGlob ast = do let nodes = SYB.everything (<>) extract ast let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey annsMap = Map.fromListWith - (flip const) + (const id) [ (GHC.realSrcSpanEnd span, annKey) | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes ] @@ -174,8 +174,8 @@ commentAnnFixTransformGlob ast = do in Map.insert annKey2 ann2' anns _ -> return True -- retain comment at current node. - priors' <- flip filterM priors processCom - follows' <- flip filterM follows $ processCom + priors' <- filterM processCom priors + follows' <- filterM processCom follows assocs' <- flip filterM assocs $ \case (ExactPrint.AnnComment com, dp) -> processCom (com, dp) _ -> return True @@ -286,7 +286,7 @@ foldedAnnKeys ast = SYB.everything ( \x -> maybe Set.empty Set.singleton - [ SYB.gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x + [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x -- for some reason, ghc-8.8 has forgotten how to infer the type of l, diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 1d8f48a..422c7be 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -36,11 +36,10 @@ import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.ExactPrintUtils import GHC.Types.Name.Reader ( RdrName(..) ) -import GHC ( Located, GenLocated(L), moduleNameString ) +import GHC ( Located, GenLocated(L), moduleName, moduleNameString ) import qualified GHC.Types.SrcLoc as GHC import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name ( getOccString ) -import GHC ( moduleName ) import GHC.Parser.Annotation ( AnnKeywordId(..) ) import Data.Data diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 49f615a..acbe186 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -37,13 +37,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- fmap return $ createBndrDoc bndrs + tyVarLine <- return <$> createBndrDoc bndrs -- headDoc <- fmap return $ docSeq -- [ appSep $ docLitS "newtype") -- , appSep $ docLit nameStr -- , appSep tyVarLine -- ] - rhsDoc <- fmap return $ createDetailsDoc consNameStr details + rhsDoc <- return <$> createDetailsDoc consNameStr details createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "newtype" , appSep $ docLit nameStr @@ -62,7 +62,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name - tyVarLine <- fmap return $ createBndrDoc bndrs + tyVarLine <- return <$> createBndrDoc bndrs createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "data" , lhsContextDoc @@ -79,14 +79,14 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- fmap return $ createBndrDoc bndrs + tyVarLine <- return <$> createBndrDoc bndrs forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x rhsContextDocMay <- case mRhsContext of Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- fmap return $ createDetailsDoc consNameStr details + rhsDoc <- return <$> createDetailsDoc consNameStr details consDoc <- fmap pure $ docNonBottomSpacing $ case (forallDocMay, rhsContextDocMay) of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index a2d4a00..a96ae47 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -162,7 +162,7 @@ layoutBind lbind@(L _ bind) = case bind of patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lbind, d) -- TODO: is this the right AnnKey? + let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing @@ -206,7 +206,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of let unordered = [ BagBind b | b <- Data.Foldable.toList bindlrs ] ++ [ BagSig s | s <- sigs ] - ordered = sortBy (comparing $ ExactPrint.rs . bindOrSigtoSrcSpan) unordered + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s @@ -271,7 +271,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do $ (List.intersperse docSeparator $ docForceSingleline <$> ps) clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) + let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch layoutPatternBindFinal alignmentToken @@ -331,7 +331,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha -- be shared between alternatives. wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of Nothing -> return $ [] - Just (annKeyWhere, [w]) -> fmap (pure . pure) $ docAlt + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt [ docEnsureIndent BrIndentRegular $ docSeq [ docLit $ Text.pack "where" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index b26687c..344454c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -595,7 +595,7 @@ layoutExpr lexpr@(L _ expr) = do expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap (fmap pure)) $ layoutLocalBinds binds + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a ifIndentFreeElse x y = diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 06aa0cf..39b7a49 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -55,7 +55,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) where - nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName + nameDoc = docLit <=< lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] @@ -208,9 +208,9 @@ lieToText = \case -- Need to check, and either put them at the top (for module) or do some -- other clever thing. L _ (IEModuleContents _ n) -> moduleNameToText n - L _ (IEGroup _ _ _ ) -> Text.pack "@IEGroup" - L _ (IEDoc _ _ ) -> Text.pack "@IEDoc" - L _ (IEDocNamed _ _ ) -> Text.pack "@IEDocNamed" + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" where moduleNameToText :: Located ModuleName -> Text moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index f5efb7f..ed0dd26 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -645,7 +645,7 @@ getBinders x = case x of XHsForAllTelescope _ -> [] withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass -withoutSpecificity = fmap $ \ x -> case x of +withoutSpecificity = fmap $ \case UserTyVar a _ c -> UserTyVar a () c KindedTyVar a _ c d -> KindedTyVar a () c d XTyVarBndr a -> XTyVarBndr a diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index d09b788..87a0c0a 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -14,44 +14,22 @@ import GHC.Types.Name.Reader as E ( RdrName ) import Data.Functor.Identity as E ( Identity(..) ) import Control.Concurrent.Chan as E ( Chan ) -import Control.Concurrent.MVar as E ( MVar ) +import Control.Concurrent.MVar as E ( MVar + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , takeMVar + , swapMVar + ) import Data.Int as E ( Int ) -import Data.Word as E ( Word ) +import Data.Word as E ( Word + , Word32 + ) 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.Monoid as E ( Endo(..) - , All(..) - , Any(..) - , Sum(..) - , Product(..) - , Alt(..) - ) -import Data.Ord as E ( Ordering(..) - , Down(..) - ) -import Data.Ratio as E ( Ratio - , Rational - ) -import Data.String as E ( String ) -import Data.Void as E ( Void ) -import System.IO as E ( IO ) -import Data.Proxy as E ( Proxy(..) ) -import Data.Sequence as E ( Seq ) - -import Data.Map as E ( Map ) -import Data.Set as E ( Set ) - -import Data.Text as E ( Text ) - -import Prelude as E ( undefined + , undefined , Eq (..) , Ord (..) , Enum (..) @@ -101,8 +79,58 @@ import Prelude as E ( undefined , Foldable , Traversable ) +import Control.Monad.ST as E ( ST ) +import Data.Bool as E ( Bool(..) ) +import Data.Char as E ( Char + , ord + , chr + ) +import Data.Either as E ( Either(..) + , either + ) +import Data.IORef as E ( IORef ) +import Data.Maybe as E ( Maybe(..) + , fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + ) +import Data.Monoid as E ( Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + , Alt(..) + , mconcat + , Monoid (..) + ) +import Data.Ord as E ( Ordering(..) + , Down(..) + , comparing + ) +import Data.Ratio as E ( Ratio + , Rational + , (%) + , numerator + , denominator + ) +import Data.String as E ( String ) +import Data.Void as E ( Void ) +import System.IO as E ( IO + , hFlush + , stdout + ) +import Data.Proxy as E ( Proxy(..) ) +import Data.Sequence as E ( Seq ) + +import Data.Map as E ( Map ) +import Data.Set as E ( Set ) + +import Data.Text as E ( Text ) import Data.Function as E ( fix + , (&) ) import Data.Foldable as E ( foldl' @@ -153,31 +181,6 @@ import Data.List.NonEmpty as E ( NonEmpty(..) import Data.Tuple as E ( swap ) -import Data.Char as E ( ord - , chr - ) - -import Data.Maybe as E ( fromMaybe - , maybe - , listToMaybe - , maybeToList - , catMaybes - ) - -import Data.Word as E ( Word32 - ) - -import Data.Ord as E ( comparing - ) - -import Data.Either as E ( either - ) - -import Data.Ratio as E ( (%) - , numerator - , denominator - ) - import Text.Read as E ( readMaybe ) @@ -222,14 +225,6 @@ import Control.Concurrent as E ( threadDelay , forkOS ) -import Control.Concurrent.MVar as E ( newEmptyMVar - , newMVar - , putMVar - , readMVar - , takeMVar - , swapMVar - ) - import Control.Exception as E ( evaluate , bracket , assert @@ -249,19 +244,11 @@ import Debug.Trace as E ( trace import Foreign.ForeignPtr as E ( ForeignPtr ) -import Data.Monoid as E ( mconcat - , Monoid (..) - ) - import Data.Bifunctor as E ( bimap ) import Data.Functor as E ( ($>) ) -import Data.Function as E ( (&) ) import Data.Semigroup as E ( (<>) , Semigroup(..) ) -import System.IO as E ( hFlush - , stdout - ) import Data.Typeable as E ( Typeable ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 57461ca..ca79995 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -206,8 +206,7 @@ transformAlts = (zip spacings alts <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) ( hasSpace1 lconf acp vs && lineCheck vs, bd)) - id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) - $ rec + rec $ fromMaybe (-- trace ("choosing last") $ List.last alts) $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> @@ -233,8 +232,7 @@ transformAlts = && any lineCheck vs, bd)) let checkedOptions :: [Maybe (Int, BriDocNumbered)] = zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) - id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) - $ rec + rec $ fromMaybe (-- trace ("choosing last") $ List.last alts) $ Data.List.Extra.firstJust (fmap snd) checkedOptions @@ -325,7 +323,7 @@ transformAlts = LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do acp <- mGet mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid (VerticalSpacing _ _ _) -> error "processSpacingSimple par" + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" _ -> error "ghc exhaustive check is insufficient" hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool hasSpace1 _ _ LineModeInvalid = False @@ -630,9 +628,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFLit t -> return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] BDFSeq list -> - fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list BDFCols _sig list -> - fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list BDFSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False] BDFAddBaseY indent bd -> do diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 55c3746..76b7735 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} @@ -19,7 +18,7 @@ import Language.Haskell.Brittany.Internal.Prelude import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data import qualified Data.Strict.Maybe as Strict -import qualified Safe as Safe +import qualified Safe import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types @@ -423,7 +422,7 @@ briDocSeqSpine = \case BDIndentLevelPushCur bd -> briDocSeqSpine bd BDIndentLevelPop bd -> briDocSeqSpine bd BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts + BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts BDForwardLineMode bd -> briDocSeqSpine bd BDExternal{} -> () BDPlain{} -> () @@ -431,7 +430,7 @@ briDocSeqSpine = \case BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationRest _annKey bd -> briDocSeqSpine bd BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines + BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd BDForceSingleline bd -> briDocSeqSpine bd diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs index 7df86d5..87ebe66 100644 --- a/src/Language/Haskell/Brittany/Main.hs +++ b/src/Language/Haskell/Brittany/Main.hs @@ -240,7 +240,7 @@ mainCmdParser helpDesc = do outputPaths if checkMode - then when (any (== Changes) (Data.Either.rights results)) + then when (Changes `elem` (Data.Either.rights results)) $ System.Exit.exitWith (System.Exit.ExitFailure 1) else case results of xs | all Data.Either.isRight xs -> pure () @@ -310,7 +310,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let hackTransform = if hackAroundIncludes && not exactprintOnly then List.intercalate "\n" . fmap hackF . lines' else id - inputString <- liftIO $ System.IO.hGetContents System.IO.stdin + inputString <- liftIO System.IO.getContents parseRes <- liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc @@ -376,8 +376,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let out = TextL.toStrict $ if hackAroundIncludes then TextL.intercalate (TextL.pack "\n") - $ fmap hackF - $ TextL.splitOn (TextL.pack "\n") outRaw + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out @@ -389,7 +389,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorMacroConfig{} = 5 - when (not $ null errsWarns) $ do + unless (null errsWarns) $ do let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder @@ -442,9 +442,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = -- adds some override? let hasErrors = - case config & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns + if config & _conf_errorHandling & _econf_Werror & confUnpack + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) outputOnErrs = config & _conf_errorHandling -- 2.30.2 From 95017640a80f60156557faf818a8c0c707ba38b8 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:06:23 +0000 Subject: [PATCH 434/478] Move executable --- brittany.cabal | 4 ++-- {src-brittany => source/executable}/Main.hs | 0 2 files changed, 2 insertions(+), 2 deletions(-) rename {src-brittany => source/executable}/Main.hs (100%) diff --git a/brittany.cabal b/brittany.cabal index 780ccaf..86a8e8f 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -137,8 +137,8 @@ executable brittany if flag(brittany-dev-lib) buildable: False - main-is: Main.hs - hs-source-dirs: src-brittany + hs-source-dirs: source/executable + main-is: Main.hs test-suite unittests import: executable diff --git a/src-brittany/Main.hs b/source/executable/Main.hs similarity index 100% rename from src-brittany/Main.hs rename to source/executable/Main.hs -- 2.30.2 From 2ab406471b94acbdae6a21bad0ebace08c55a3c2 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:07:34 +0000 Subject: [PATCH 435/478] Move library --- brittany.cabal | 5 ++--- {src => source/library}/Language/Haskell/Brittany.hs | 0 .../library}/Language/Haskell/Brittany/Internal.hs | 0 .../library}/Language/Haskell/Brittany/Internal/Backend.hs | 0 .../Language/Haskell/Brittany/Internal/BackendUtils.hs | 0 .../library}/Language/Haskell/Brittany/Internal/Config.hs | 0 .../Language/Haskell/Brittany/Internal/Config/Types.hs | 0 .../Haskell/Brittany/Internal/Config/Types/Instances.hs | 0 .../Language/Haskell/Brittany/Internal/ExactPrintUtils.hs | 0 .../Language/Haskell/Brittany/Internal/LayouterBasics.hs | 0 .../Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs | 0 .../Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 0 .../Language/Haskell/Brittany/Internal/Layouters/Expr.hs | 0 .../Haskell/Brittany/Internal/Layouters/Expr.hs-boot | 0 .../Language/Haskell/Brittany/Internal/Layouters/IE.hs | 0 .../Language/Haskell/Brittany/Internal/Layouters/Import.hs | 0 .../Language/Haskell/Brittany/Internal/Layouters/Module.hs | 0 .../Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 0 .../Language/Haskell/Brittany/Internal/Layouters/Stmt.hs | 0 .../Haskell/Brittany/Internal/Layouters/Stmt.hs-boot | 0 .../Language/Haskell/Brittany/Internal/Layouters/Type.hs | 0 .../Language/Haskell/Brittany/Internal/Obfuscation.hs | 0 .../library}/Language/Haskell/Brittany/Internal/Prelude.hs | 0 .../Language/Haskell/Brittany/Internal/PreludeUtils.hs | 0 .../Haskell/Brittany/Internal/Transformations/Alt.hs | 0 .../Haskell/Brittany/Internal/Transformations/Columns.hs | 0 .../Haskell/Brittany/Internal/Transformations/Floating.hs | 0 .../Haskell/Brittany/Internal/Transformations/Indent.hs | 0 .../Haskell/Brittany/Internal/Transformations/Par.hs | 0 .../library}/Language/Haskell/Brittany/Internal/Types.hs | 0 .../library}/Language/Haskell/Brittany/Internal/Utils.hs | 0 {src => source/library}/Language/Haskell/Brittany/Main.hs | 0 32 files changed, 2 insertions(+), 3 deletions(-) rename {src => source/library}/Language/Haskell/Brittany.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Backend.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/BackendUtils.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Config.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Config/Types.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/LayouterBasics.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Decl.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Expr.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/IE.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Import.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Module.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Layouters/Type.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Obfuscation.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Prelude.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/PreludeUtils.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Transformations/Alt.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Transformations/Columns.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Transformations/Floating.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Transformations/Indent.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Transformations/Par.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Types.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Internal/Utils.hs (100%) rename {src => source/library}/Language/Haskell/Brittany/Main.hs (100%) diff --git a/brittany.cabal b/brittany.cabal index 86a8e8f..7b238ec 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -96,8 +96,8 @@ common executable library import: library - hs-source-dirs: - src + autogen-modules: Paths_brittany + hs-source-dirs: source/library exposed-modules: Language.Haskell.Brittany Language.Haskell.Brittany.Internal @@ -129,7 +129,6 @@ library Language.Haskell.Brittany.Internal.Utils Language.Haskell.Brittany.Main Paths_brittany - autogen-modules: Paths_brittany executable brittany import: executable diff --git a/src/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs similarity index 100% rename from src/Language/Haskell/Brittany.hs rename to source/library/Language/Haskell/Brittany.hs diff --git a/src/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal.hs rename to source/library/Language/Haskell/Brittany/Internal.hs diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Backend.hs rename to source/library/Language/Haskell/Brittany/Internal/Backend.hs diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/BackendUtils.hs rename to source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Config.hs rename to source/library/Language/Haskell/Brittany/Internal/Config.hs diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Config/Types.hs rename to source/library/Language/Haskell/Brittany/Internal/Config/Types.hs diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs rename to source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs rename to source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/LayouterBasics.hs rename to source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/IE.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Import.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Module.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Layouters/Type.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Obfuscation.hs rename to source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Prelude.hs rename to source/library/Language/Haskell/Brittany/Internal/Prelude.hs diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/PreludeUtils.hs rename to source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Transformations/Par.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Types.hs rename to source/library/Language/Haskell/Brittany/Internal/Types.hs diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs similarity index 100% rename from src/Language/Haskell/Brittany/Internal/Utils.hs rename to source/library/Language/Haskell/Brittany/Internal/Utils.hs diff --git a/src/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs similarity index 100% rename from src/Language/Haskell/Brittany/Main.hs rename to source/library/Language/Haskell/Brittany/Main.hs -- 2.30.2 From 75aed1cb8a44816baedc5cc50149dfd796a9b0fd Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:11:27 +0000 Subject: [PATCH 436/478] Remove unnecessary GHC version parsing --- src-literatetests/10-tests.blt | 3 --- src-literatetests/14-extensions.blt | 5 ++--- src-literatetests/Main.hs | 25 ++----------------------- 3 files changed, 4 insertions(+), 29 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index aa3c7cb..75babb0 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -446,7 +446,6 @@ data Foo = Bar deriving (Show, Eq, Monad, Functor, Traversable, Foldable) #test record multiple deriving strategies -#min-ghc 8.2 data Foo = Bar { foo :: Baz , bars :: Bizzz @@ -461,7 +460,6 @@ data Foo = Bar deriving newtype (Traversable, Foldable) #test record deriving via -#min-ghc 8.6 data Foo = Bar { foo :: Baz , bars :: Bizzz @@ -535,7 +533,6 @@ data Foo = Bar ## maybe we want to switch to a differnt layout when there are such comments. ## Don't hesitate to modify this testcase, it clearly is not the ideal layout ## for this. -#min-ghc 8.6 data Foo = Bar { foo :: Baz diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt index d794e9c..18fc24f 100644 --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -121,7 +121,7 @@ pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- [myLongLeftVariableName, myLongRightVariableName] where MyInfixPatternMatcher x y = [x, x, y] -#test Pattern synonym types +#test Pattern synonym types {-# LANGUAGE PatternSynonyms #-} pattern J :: a -> Maybe a pattern J x = Just x @@ -152,7 +152,6 @@ pattern Signed x <- (asSigned -> x) where Signed (Pos x) = x -- positive comment #test Pattern synonym types multiple names -#min-ghc 8.2 {-# LANGUAGE PatternSynonyms #-} pattern J, K :: a -> Maybe a @@ -239,4 +238,4 @@ foo = let ?bar = Foo in value #test IP type signature {-# LANGUAGE ImplicitParams #-} foo :: (?bar::Bool) => () -foo = () \ No newline at end of file +foo = () diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index a1dc2af..d11007b 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} import Language.Haskell.Brittany.Internal.Prelude -import qualified Data.List.Extra import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text @@ -32,7 +30,6 @@ import System.FilePath ( () ) data InputLine = GroupLine Text | HeaderLine Text - | GhcVersionGuardLine Text | PendingLine | NormalLine Text | CommentLine @@ -41,7 +38,6 @@ data InputLine data TestCase = TestCase { testName :: Text , isPending :: Bool - , minGHCVersion :: Maybe Text , content :: Text } @@ -56,26 +52,17 @@ main = do let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree - let parseVersion :: Text -> Maybe [Int] - parseVersion = - mapM (readMaybe . Text.unpack) . Text.splitOn (Text.pack ".") - let ghcVersion = Data.Maybe.fromJust $ parseVersion $ Text.pack VERSION_ghc - let checkVersion = \case - Nothing -> True -- no version constraint - Just s -> case parseVersion s of - Nothing -> error $ "could not parse version " ++ Text.unpack s - Just v -> v <= ghcVersion hspec $ do groups `forM_` \(groupname, tests) -> do describe (Text.unpack groupname) $ do - tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + tests `forM_` \test -> do (if isPending test then before_ pending else id) $ it (Text.unpack $ testName test) $ roundTripEqual defaultTestConfig $ content test groupsCtxFree `forM_` \(groupname, tests) -> do describe ("context free: " ++ Text.unpack groupname) $ do - tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + tests `forM_` \test -> do (if isPending test then before_ pending else id) $ it (Text.unpack $ testName test) $ roundTripEqual contextFreeTestConfig @@ -113,15 +100,12 @@ main = do in TestCase { testName = n , isPending = any isPendingLine rest - , minGHCVersion = Data.List.Extra.firstJust extractMinGhc rest , content = Text.unlines normalLines } l -> error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l extractNormal _ = Nothing - extractMinGhc (GhcVersionGuardLine v) = Just v - extractMinGhc _ = Nothing isPendingLine PendingLine{} = True isPendingLine _ = False specialLineParser :: Parser InputLine @@ -138,11 +122,6 @@ main = do , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , _ <- Parsec.eof ] - , [ GhcVersionGuardLine $ Text.pack version - | _ <- Parsec.try $ Parsec.string "#min-ghc" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" - , version <- Parsec.many1 $ Parsec.noneOf "\r\n:" - ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") -- 2.30.2 From 0c720ee032c0d88d9beb3420bbc671fd780d32dc Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:12:57 +0000 Subject: [PATCH 437/478] Remove unnecessary flags --- brittany.cabal | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 7b238ec..7eaa0d7 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -30,16 +30,6 @@ source-repository head type: git location: https://github.com/lspitzner/brittany.git -flag brittany-dev-lib - description: set buildable false for anything but lib - default: False - manual: True - -flag brittany-test-perf - description: determines if performance test suite is enabled - default: False - manual: True - common library build-depends: , aeson ^>= 2.0.1 @@ -133,18 +123,12 @@ library executable brittany import: executable - if flag(brittany-dev-lib) - buildable: False - hs-source-dirs: source/executable main-is: Main.hs test-suite unittests import: executable - if flag(brittany-dev-lib) || !flag(brittany-test-perf) - buildable: False - type: exitcode-stdio-1.0 build-depends: , hspec ^>= 2.8.3 @@ -156,9 +140,6 @@ test-suite unittests test-suite littests import: executable - if flag(brittany-dev-lib) - buildable: False - type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: @@ -170,9 +151,6 @@ test-suite littests test-suite libinterfacetests import: executable - if flag(brittany-dev-lib) - buildable: False - type: exitcode-stdio-1.0 build-depends: , hspec ^>= 2.8.3 -- 2.30.2 From c2248cb99c6aec3d494ba1612c825000f99bba80 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:15:03 +0000 Subject: [PATCH 438/478] Ignore missed specializations --- brittany.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/brittany.cabal b/brittany.cabal index 7eaa0d7..ffd8d42 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -63,6 +63,7 @@ common library default-language: Haskell2010 ghc-options: -Weverything + -Wno-all-missed-specialisations -Wno-incomplete-uni-patterns -Wno-missing-deriving-strategies -Wno-missing-export-lists -- 2.30.2 From d879125264fa3bcc3f94bfd3d5aa8f72159fb20a Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:17:57 +0000 Subject: [PATCH 439/478] Combine unit test modules --- brittany.cabal | 3 +- src-unittests/AsymptoticPerfTests.hs | 37 ----------- src-unittests/TestMain.hs | 99 +++++++++++++++++++++++++++- src-unittests/TestUtils.hs | 75 --------------------- 4 files changed, 99 insertions(+), 115 deletions(-) delete mode 100644 src-unittests/AsymptoticPerfTests.hs delete mode 100644 src-unittests/TestUtils.hs diff --git a/brittany.cabal b/brittany.cabal index ffd8d42..ee0035b 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -72,6 +72,7 @@ common library -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module + -Wno-safe -Wno-unsafe common executable @@ -134,8 +135,6 @@ test-suite unittests build-depends: , hspec ^>= 2.8.3 main-is: TestMain.hs - other-modules: TestUtils - AsymptoticPerfTests hs-source-dirs: src-unittests test-suite littests diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs deleted file mode 100644 index 702ab90..0000000 --- a/src-unittests/AsymptoticPerfTests.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module AsymptoticPerfTests where - - - -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Data.Text as Text - -import Test.Hspec - -import TestUtils - - - -asymptoticPerfTest :: Spec -asymptoticPerfTest = do - it "10 do statements" - $ roundTripEqualWithTimeout 1500000 - $ (Text.pack "func = do\n") - <> Text.replicate 10 (Text.pack " statement\n") - it "10 do nestings" - $ roundTripEqualWithTimeout 4000000 - $ (Text.pack "func = ") - <> mconcat - ( [1 .. 10] - <&> \(i :: Int) -> - (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") - ) - <> Text.replicate 2000 (Text.pack " ") - <> Text.pack "return\n" - <> Text.replicate 2002 (Text.pack " ") - <> Text.pack "()" - it "10 AppOps" - $ roundTripEqualWithTimeout 1000000 - $ (Text.pack "func = expr") - <> Text.replicate 10 (Text.pack "\n . expr") --TODO diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs index 2f0f894..33af44b 100644 --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -1,6 +1,103 @@ +{-# LANGUAGE ScopedTypeVariables #-} + import Test.Hspec -import AsymptoticPerfTests +import Language.Haskell.Brittany.Internal.Prelude +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text + +import Language.Haskell.Brittany.Internal + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config + +import System.Timeout ( timeout ) + +import Data.Coerce ( coerce ) + + + +import Language.Haskell.Brittany.Internal.PreludeUtils + + + +asymptoticPerfTest :: Spec +asymptoticPerfTest = do + it "10 do statements" + $ roundTripEqualWithTimeout 1500000 + $ (Text.pack "func = do\n") + <> Text.replicate 10 (Text.pack " statement\n") + it "10 do nestings" + $ roundTripEqualWithTimeout 4000000 + $ (Text.pack "func = ") + <> mconcat + ( [1 .. 10] + <&> \(i :: Int) -> + (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") + ) + <> Text.replicate 2000 (Text.pack " ") + <> Text.pack "return\n" + <> Text.replicate 2002 (Text.pack " ") + <> Text.pack "()" + it "10 AppOps" + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = expr") + <> Text.replicate 10 (Text.pack "\n . expr") --TODO + + + +roundTripEqual :: Text -> Expectation +roundTripEqual t = + fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + `shouldReturn` Right (PPTextWrapper t) + +roundTripEqualWithTimeout :: Int -> Text -> Expectation +roundTripEqualWithTimeout time t = + timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) + where + action = fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + +newtype PPTextWrapper = PPTextWrapper Text + deriving Eq + +instance Show PPTextWrapper where + show (PPTextWrapper t) = "\n" ++ Text.unpack t + +defaultTestConfig :: Config +defaultTestConfig = Config + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_experimentalSemicolonNewlines = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False + } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) + { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever + } + , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) + , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False + } diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs deleted file mode 100644 index 942f4aa..0000000 --- a/src-unittests/TestUtils.hs +++ /dev/null @@ -1,75 +0,0 @@ -module TestUtils where - - - -import Language.Haskell.Brittany.Internal.Prelude -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text - -import Test.Hspec - --- import NeatInterpolation - -import Language.Haskell.Brittany.Internal - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config - -import System.Timeout ( timeout ) - -import Data.Coerce ( coerce ) - - - -roundTripEqual :: Text -> Expectation -roundTripEqual t = - fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) - `shouldReturn` Right (PPTextWrapper t) - -roundTripEqualWithTimeout :: Int -> Text -> Expectation -roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) - where - action = fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) - -newtype PPTextWrapper = PPTextWrapper Text - deriving Eq - -instance Show PPTextWrapper where - show (PPTextWrapper t) = "\n" ++ Text.unpack t - -defaultTestConfig :: Config -defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) - { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever - } - , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) - , _conf_forward = ForwardOptions {_options_ghc = Identity []} - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } -- 2.30.2 From 9a9b67d410de28356dfb7975d59d407d8f5e9c6c Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:21:11 +0000 Subject: [PATCH 440/478] Merge unit tests into literate tests --- brittany.cabal | 9 ---- src-literatetests/Main.hs | 39 ++++++++++++++ src-unittests/TestMain.hs | 109 -------------------------------------- 3 files changed, 39 insertions(+), 118 deletions(-) delete mode 100644 src-unittests/TestMain.hs diff --git a/brittany.cabal b/brittany.cabal index ee0035b..d659a6a 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -128,15 +128,6 @@ executable brittany hs-source-dirs: source/executable main-is: Main.hs -test-suite unittests - import: executable - - type: exitcode-stdio-1.0 - build-depends: - , hspec ^>= 2.8.3 - main-is: TestMain.hs - hs-source-dirs: src-unittests - test-suite littests import: executable diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index d11007b..e97252d 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE ScopedTypeVariables #-} import Language.Haskell.Brittany.Internal.Prelude import qualified Data.Maybe @@ -25,6 +26,43 @@ import Data.Coerce ( coerce ) import qualified Data.Text.IO as Text.IO import System.FilePath ( () ) +import System.Timeout ( timeout ) + + + +import Language.Haskell.Brittany.Internal.PreludeUtils + + + +asymptoticPerfTest :: Spec +asymptoticPerfTest = do + it "10 do statements" + $ roundTripEqualWithTimeout 1500000 + $ (Text.pack "func = do\n") + <> Text.replicate 10 (Text.pack " statement\n") + it "10 do nestings" + $ roundTripEqualWithTimeout 4000000 + $ (Text.pack "func = ") + <> mconcat + ( [1 .. 10] + <&> \(i :: Int) -> + (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") + ) + <> Text.replicate 2000 (Text.pack " ") + <> Text.pack "return\n" + <> Text.replicate 2002 (Text.pack " ") + <> Text.pack "()" + it "10 AppOps" + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = expr") + <> Text.replicate 10 (Text.pack "\n . expr") --TODO + +roundTripEqualWithTimeout :: Int -> Text -> Expectation +roundTripEqualWithTimeout time t = + timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) + where + action = fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) data InputLine @@ -53,6 +91,7 @@ main = do inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree hspec $ do + describe "asymptotic perf roundtrips" $ asymptoticPerfTest groups `forM_` \(groupname, tests) -> do describe (Text.unpack groupname) $ do tests `forM_` \test -> do diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs deleted file mode 100644 index 33af44b..0000000 --- a/src-unittests/TestMain.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -import Test.Hspec - -import Language.Haskell.Brittany.Internal.Prelude -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text - -import Language.Haskell.Brittany.Internal - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config - -import System.Timeout ( timeout ) - -import Data.Coerce ( coerce ) - - - -import Language.Haskell.Brittany.Internal.PreludeUtils - - - -asymptoticPerfTest :: Spec -asymptoticPerfTest = do - it "10 do statements" - $ roundTripEqualWithTimeout 1500000 - $ (Text.pack "func = do\n") - <> Text.replicate 10 (Text.pack " statement\n") - it "10 do nestings" - $ roundTripEqualWithTimeout 4000000 - $ (Text.pack "func = ") - <> mconcat - ( [1 .. 10] - <&> \(i :: Int) -> - (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") - ) - <> Text.replicate 2000 (Text.pack " ") - <> Text.pack "return\n" - <> Text.replicate 2002 (Text.pack " ") - <> Text.pack "()" - it "10 AppOps" - $ roundTripEqualWithTimeout 1000000 - $ (Text.pack "func = expr") - <> Text.replicate 10 (Text.pack "\n . expr") --TODO - - - -roundTripEqual :: Text -> Expectation -roundTripEqual t = - fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) - `shouldReturn` Right (PPTextWrapper t) - -roundTripEqualWithTimeout :: Int -> Text -> Expectation -roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) - where - action = fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) - -newtype PPTextWrapper = PPTextWrapper Text - deriving Eq - -instance Show PPTextWrapper where - show (PPTextWrapper t) = "\n" ++ Text.unpack t - -defaultTestConfig :: Config -defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) - { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever - } - , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) - , _conf_forward = ForwardOptions {_options_ghc = Identity []} - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } - - - -main :: IO () -main = hspec $ tests - -tests :: Spec -tests = do - describe "asymptotic perf roundtrips" $ asymptoticPerfTest -- 2.30.2 From 5631e2500fc762600c3149d1720fcc5fa0c1cd61 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:23:06 +0000 Subject: [PATCH 441/478] Merge interface tests into literate tests --- brittany.cabal | 9 --------- src-libinterfacetests/Main.hs | 27 --------------------------- src-literatetests/Main.hs | 18 ++++++++++++++++++ 3 files changed, 18 insertions(+), 36 deletions(-) delete mode 100644 src-libinterfacetests/Main.hs diff --git a/brittany.cabal b/brittany.cabal index d659a6a..3589ed9 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -138,12 +138,3 @@ test-suite littests , parsec ^>= 3.1.14 main-is: Main.hs hs-source-dirs: src-literatetests - -test-suite libinterfacetests - import: executable - - type: exitcode-stdio-1.0 - build-depends: - , hspec ^>= 2.8.3 - main-is: Main.hs - hs-source-dirs: src-libinterfacetests diff --git a/src-libinterfacetests/Main.hs b/src-libinterfacetests/Main.hs deleted file mode 100644 index 2d1924f..0000000 --- a/src-libinterfacetests/Main.hs +++ /dev/null @@ -1,27 +0,0 @@ -import Test.Hspec -import Language.Haskell.Brittany -import qualified Data.Text as Text -import Control.Monad.IO.Class - - - -main :: IO () -main = hspec $ do - describe "library interface basic functionality" $ do - it "gives properly formatted result for valid input" $ do - let - input = Text.pack $ unlines - ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] - let expected = Text.pack $ unlines - [ "func =" - , " [ 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " ]" - ] - output <- liftIO $ parsePrintModule staticDefaultConfig input - hush output `shouldBe` Just expected - -hush :: Either a b -> Maybe b -hush = either (const Nothing) Just diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index e97252d..dbc2ee5 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -32,6 +32,9 @@ import System.Timeout ( timeout ) import Language.Haskell.Brittany.Internal.PreludeUtils +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just + asymptoticPerfTest :: Spec @@ -92,6 +95,21 @@ main = do let groupsCtxFree = createChunks inputCtxFree hspec $ do describe "asymptotic perf roundtrips" $ asymptoticPerfTest + describe "library interface basic functionality" $ do + it "gives properly formatted result for valid input" $ do + let + input = Text.pack $ unlines + ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] + let expected = Text.pack $ unlines + [ "func =" + , " [ 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " ]" + ] + output <- liftIO $ parsePrintModule staticDefaultConfig input + hush output `shouldBe` Just expected groups `forM_` \(groupname, tests) -> do describe (Text.unpack groupname) $ do tests `forM_` \test -> do -- 2.30.2 From 93ba90e64615e4139b4f28a9e95616b897cd1a4b Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:23:49 +0000 Subject: [PATCH 442/478] Rename test suite --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 3589ed9..a7cacdc 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -128,7 +128,7 @@ executable brittany hs-source-dirs: source/executable main-is: Main.hs -test-suite littests +test-suite brittany-test-suite import: executable type: exitcode-stdio-1.0 -- 2.30.2 From 79be0ed2002c94d5f217c66c0d2894c5cf5ca085 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:25:04 +0000 Subject: [PATCH 443/478] Move test suite --- brittany.cabal | 7 +++---- {src-literatetests => source/test-suite}/Main.hs | 0 2 files changed, 3 insertions(+), 4 deletions(-) rename {src-literatetests => source/test-suite}/Main.hs (100%) diff --git a/brittany.cabal b/brittany.cabal index a7cacdc..4fafd8d 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -131,10 +131,9 @@ executable brittany test-suite brittany-test-suite import: executable - type: exitcode-stdio-1.0 - default-language: Haskell2010 build-depends: , hspec ^>= 2.8.3 , parsec ^>= 3.1.14 - main-is: Main.hs - hs-source-dirs: src-literatetests + hs-source-dirs: source/test-suite + main-is: Main.hs + type: exitcode-stdio-1.0 diff --git a/src-literatetests/Main.hs b/source/test-suite/Main.hs similarity index 100% rename from src-literatetests/Main.hs rename to source/test-suite/Main.hs -- 2.30.2 From e22a647baaba25424dfd04028aae9dca05707e7c Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:28:23 +0000 Subject: [PATCH 444/478] Move literate test files --- brittany.cabal | 2 +- {src-literatetests => data}/10-tests.blt | 0 {src-literatetests => data}/14-extensions.blt | 0 {src-literatetests => data}/15-regressions.blt | 0 {src-literatetests => data}/16-pending.blt | 0 {src-literatetests => data}/30-tests-context-free.blt | 0 {src-literatetests => data}/40-indent-policy-multiple.blt | 0 source/test-suite/Main.hs | 6 +++--- 8 files changed, 4 insertions(+), 4 deletions(-) rename {src-literatetests => data}/10-tests.blt (100%) rename {src-literatetests => data}/14-extensions.blt (100%) rename {src-literatetests => data}/15-regressions.blt (100%) rename {src-literatetests => data}/16-pending.blt (100%) rename {src-literatetests => data}/30-tests-context-free.blt (100%) rename {src-literatetests => data}/40-indent-policy-multiple.blt (100%) diff --git a/brittany.cabal b/brittany.cabal index 4fafd8d..d8574e4 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -24,7 +24,7 @@ extra-doc-files: README.md doc/implementation/*.md extra-source-files: - src-literatetests/*.blt + data/*.blt source-repository head type: git diff --git a/src-literatetests/10-tests.blt b/data/10-tests.blt similarity index 100% rename from src-literatetests/10-tests.blt rename to data/10-tests.blt diff --git a/src-literatetests/14-extensions.blt b/data/14-extensions.blt similarity index 100% rename from src-literatetests/14-extensions.blt rename to data/14-extensions.blt diff --git a/src-literatetests/15-regressions.blt b/data/15-regressions.blt similarity index 100% rename from src-literatetests/15-regressions.blt rename to data/15-regressions.blt diff --git a/src-literatetests/16-pending.blt b/data/16-pending.blt similarity index 100% rename from src-literatetests/16-pending.blt rename to data/16-pending.blt diff --git a/src-literatetests/30-tests-context-free.blt b/data/30-tests-context-free.blt similarity index 100% rename from src-literatetests/30-tests-context-free.blt rename to data/30-tests-context-free.blt diff --git a/src-literatetests/40-indent-policy-multiple.blt b/data/40-indent-policy-multiple.blt similarity index 100% rename from src-literatetests/40-indent-policy-multiple.blt rename to data/40-indent-policy-multiple.blt diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index dbc2ee5..774088f 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -84,14 +84,14 @@ data TestCase = TestCase main :: IO () main = do - files <- System.Directory.listDirectory "src-literatetests/" + files <- System.Directory.listDirectory "data/" let blts = List.sort $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) $ filter (".blt" `isSuffixOf`) files - inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) + inputs <- blts `forM` \blt -> Text.IO.readFile ("data" blt) let groups = createChunks =<< inputs - inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" + inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree hspec $ do describe "asymptotic perf roundtrips" $ asymptoticPerfTest -- 2.30.2 From 93172bfd21386be2022c669d6a9f5a8402aeb6cb Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:30:05 +0000 Subject: [PATCH 445/478] Add flag for turning warnings into errors --- .github/workflows/ci.yaml | 2 +- brittany.cabal | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index cc3cd3e..ce15348 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -25,7 +25,7 @@ jobs: with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} - - run: cabal configure --enable-tests + - run: cabal configure --enable-tests --flags pedantic --jobs - run: cabal freeze - run: cat cabal.project.freeze - uses: actions/cache@v2 diff --git a/brittany.cabal b/brittany.cabal index d8574e4..79d5b8b 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -30,6 +30,11 @@ source-repository head type: git location: https://github.com/lspitzner/brittany.git +flag pedantic + default: False + description: Enables @-Werror@, which turns warnings into errors. + manual: True + common library build-depends: , aeson ^>= 2.0.1 @@ -75,6 +80,9 @@ common library -Wno-safe -Wno-unsafe + if flag(pedantic) + ghc-options: -Werror + common executable import: library -- 2.30.2 From 694ce973f4ff7b519c467f3aae97a96681458c1f Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:31:23 +0000 Subject: [PATCH 446/478] Remove Travis CI config --- .travis.yml | 1 - 1 file changed, 1 deletion(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index ee15e0e..0000000 --- a/.travis.yml +++ /dev/null @@ -1 +0,0 @@ -language: minimal -- 2.30.2 From 51ca8fd5d7e8d8f0a7ffc63de5d6ba62141eaaba Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:31:55 +0000 Subject: [PATCH 447/478] Remove Nix configuration --- README.md | 18 ------------------ default.nix | 18 ------------------ 2 files changed, 36 deletions(-) delete mode 100644 default.nix diff --git a/README.md b/README.md index 5ee23ac..d88aed4 100644 --- a/README.md +++ b/README.md @@ -68,12 +68,6 @@ log the size of the input, but _not_ the full input/output of requests.) you may want to clone the repo and try again (there are several stack.yamls included). -- via `nix`: - ~~~.sh - nix build - nix-env -i ./result - ~~~ - - via `cabal` Due to constant changes to the cabal UI, I have given up on making sure @@ -103,18 +97,6 @@ log the size of the input, but _not_ the full input/output of requests.) # Development tips -## Run a hoogle server - -To host a local Hoogle server with all of Brittany's dependencies run: - -```sh -echo brittany.cabal | - $(nix-build '' --no-link -A entr)/bin/entr -r -- \ - sh -c "nix-shell --run 'hoogle server --local'" -``` - -This will watch `brittany.cabal` for changes and restart the server when new dependencies are added there. - # Editor Integration #### Sublime text diff --git a/default.nix b/default.nix deleted file mode 100644 index ed3dcca..0000000 --- a/default.nix +++ /dev/null @@ -1,18 +0,0 @@ -{ nixpkgsSrc ? builtins.fetchTarball { - url = - "https://github.com/nixos/nixpkgs/archive/069f183f16c3ea5d4b6e7625433b92eba77534f7.tar.gz"; # nixos-unstable - sha256 = "1by9rqvr2k6iz2yipf89yaj254yicpwq384ijgyy8p71lfxbbww2"; -}, pkgs ? import nixpkgsSrc { }, compiler ? null, forShell ? pkgs.lib.inNixShell -}: - -let - haskellPackages = if compiler == null then - pkgs.haskellPackages - else - pkgs.haskell.packages.${compiler}; - -in haskellPackages.developPackage { - name = "brittany"; - root = pkgs.nix-gitignore.gitignoreSource [ ] ./.; - returnShellEnv = forShell; -} -- 2.30.2 From a1cd4c5ed5609c418c524962590328b2f42e70cd Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:32:31 +0000 Subject: [PATCH 448/478] Remove Make configuration --- Makefile | 18 ------------------ 1 file changed, 18 deletions(-) delete mode 100644 Makefile diff --git a/Makefile b/Makefile deleted file mode 100644 index 2d5b809..0000000 --- a/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -.PHONY: test -test: - echo "test" - stack test - -.PHONY: test-all -test-all: - $(MAKE) test test-8.8.4 test-8.6.5 - -.PHONY: test-8.8.4 -test-8.8.4: - echo "test 8.8.4" - stack test --stack-yaml stack-8.8.4.yaml --work-dir .stack-work-8.8.4 - -.PHONY: test-8.6.5 -test-8.6.5: - echo "test 8.6.5" - stack test --stack-yaml stack-8.6.5.yaml --work-dir .stack-work-8.6.5 -- 2.30.2 From 4ee386a32378c09d52f1bcfd5185f86c16f671ff Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:32:54 +0000 Subject: [PATCH 449/478] Remove unnecessary setup script --- Setup.hs | 2 -- 1 file changed, 2 deletions(-) delete mode 100644 Setup.hs diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain -- 2.30.2 From fdbbe9803df873c8e0eefde0e9f3b55dd316513c Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:33:44 +0000 Subject: [PATCH 450/478] Try to spend less time compressing binaries --- .github/workflows/ci.yaml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index ce15348..e3b50a2 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -43,7 +43,6 @@ jobs: - uses: svenstaro/upx-action@v2 with: file: artifact/${{ matrix.os }}/brittany${{ matrix.ext }} - args: --best - uses: actions/upload-artifact@v2 with: path: artifact -- 2.30.2 From 208240b62feaee203c2232bf9d73278d35b907ec Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:36:35 +0000 Subject: [PATCH 451/478] Remvoe old Stack configs --- stack-8.6.5.yaml | 1 - stack-8.6.5.yaml.lock | 12 ------------ stack-8.8.4.yaml | 1 - stack-8.8.4.yaml.lock | 12 ------------ 4 files changed, 26 deletions(-) delete mode 100644 stack-8.6.5.yaml delete mode 100644 stack-8.6.5.yaml.lock delete mode 100644 stack-8.8.4.yaml delete mode 100644 stack-8.8.4.yaml.lock diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml deleted file mode 100644 index 785b146..0000000 --- a/stack-8.6.5.yaml +++ /dev/null @@ -1 +0,0 @@ -resolver: lts-14.27 diff --git a/stack-8.6.5.yaml.lock b/stack-8.6.5.yaml.lock deleted file mode 100644 index e24dcac..0000000 --- a/stack-8.6.5.yaml.lock +++ /dev/null @@ -1,12 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: [] -snapshots: -- completed: - size: 524996 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml - sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 - original: lts-14.27 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml deleted file mode 100644 index d014f95..0000000 --- a/stack-8.8.4.yaml +++ /dev/null @@ -1 +0,0 @@ -resolver: lts-16.25 diff --git a/stack-8.8.4.yaml.lock b/stack-8.8.4.yaml.lock deleted file mode 100644 index 31befa1..0000000 --- a/stack-8.8.4.yaml.lock +++ /dev/null @@ -1,12 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: [] -snapshots: -- completed: - size: 533252 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/25.yaml - sha256: 147598b98bdd95ec0409bac125a4f1bff3cd4f8d73334d283d098f66a4bcc053 - original: lts-16.25 -- 2.30.2 From ac81c5ce9033bd88e38d0a4f63d70ce06114e718 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 21:44:30 +0000 Subject: [PATCH 452/478] Update Stack config --- stack.yaml | 13 +++++++++-- stack.yaml.lock | 61 +++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 68 insertions(+), 6 deletions(-) diff --git a/stack.yaml b/stack.yaml index 9989a09..647404b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,13 @@ -resolver: nightly-2020-12-09 - +system-ghc: true +allow-newer: true +resolver: nightly-2021-11-06 extra-deps: + - aeson-2.0.1.0 + - butcher-1.3.3.2 + - Cabal-3.6.2.0 - data-tree-print-0.1.0.2 + - multistate-0.8.0.3 + - parsec-3.1.14.0 + - text-1.2.5.0 + - git: https://github.com/mithrandi/czipwith + commit: b6245884ae83e00dd2b5261762549b37390179f8 diff --git a/stack.yaml.lock b/stack.yaml.lock index 91c9355..087338e 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,27 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: +- completed: + hackage: aeson-2.0.1.0@sha256:ee0847af4d1fb9ece3f24f443d8d8406431c32688a57880314ac36617da937eb,6229 + pantry-tree: + size: 37910 + sha256: e7a9eec09f1ea56548b07c7e82b53bf32a974827ffc402d852c667b5f5d89efd + original: + hackage: aeson-2.0.1.0 +- completed: + hackage: butcher-1.3.3.2@sha256:0be5b914f648ec9c63cb88730d983602aef829a7c8c31343952e4642e6b52a84,3150 + pantry-tree: + size: 1197 + sha256: 96fe696234de07e4d9253d80ddf189f8cfaf2e262e977438343a6069677a39d2 + original: + hackage: butcher-1.3.3.2 +- completed: + hackage: Cabal-3.6.2.0@sha256:e2266e14758c1f799220fad7f0d4b0b4ec567d81b7ba3faea17ff76d4c31de95,12437 + pantry-tree: + size: 19757 + sha256: 6650e54cbbcda6d05c4d8b8094fa61e5ffbda15a798a354d2dad5b35dc3b2859 + original: + hackage: Cabal-3.6.2.0 - completed: hackage: data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620 pantry-tree: @@ -11,9 +32,41 @@ packages: sha256: b8778eb1b16fddb91b2eed2b25f33a89d1e4f7a533160de4ccbf226f82456135 original: hackage: data-tree-print-0.1.0.2 +- completed: + hackage: multistate-0.8.0.3@sha256:49d600399f3a4bfd8c8ba2e924c6592e84915b63c52970818982baa274cd9ac3,3588 + pantry-tree: + size: 2143 + sha256: 73b47c11a753963b033b79209a66490013da35854dd1064b3633dd23c3fa5650 + original: + hackage: multistate-0.8.0.3 +- completed: + hackage: text-1.2.5.0@sha256:791f0f6c97ed96113f17ab520cf0efe1a3a4f883a8c85910a5660567c8241c40,7895 + pantry-tree: + size: 7395 + sha256: f41504ec5c04a3f3358ef104362f02fdef29cbce4e5e4e6dbd6b6db70c40d4bf + original: + hackage: text-1.2.5.0 +- completed: + hackage: parsec-3.1.14.0@sha256:72d5c57e6e126adaa781ab97b19dc76f68490c0a3d88f14038219994cabe94e1,4356 + pantry-tree: + size: 2574 + sha256: 495a86688c6e89faf38b8804cc4c9216709e9a6a93cf56c2f07d5bef83f09a17 + original: + hackage: parsec-3.1.14.0 +- completed: + name: czipwith + version: 1.0.1.3 + git: https://github.com/mithrandi/czipwith + pantry-tree: + size: 964 + sha256: 239a37e26558e6272c07dc280ee07a83407ed6b86000047ddb979726c23818c4 + commit: b6245884ae83e00dd2b5261762549b37390179f8 + original: + git: https://github.com/mithrandi/czipwith + commit: b6245884ae83e00dd2b5261762549b37390179f8 snapshots: - completed: - size: 556768 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/12/9.yaml - sha256: bca31ebf05f842be9dd24410eca84f296da1860369a82eb7466f447a76cca762 - original: nightly-2020-12-09 + size: 594850 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/11/6.yaml + sha256: b5d7eef8b8b34d08a9604179e2594a9a5025d872146556b51f9d2f7bfead834b + original: nightly-2021-11-06 -- 2.30.2 From 4398b5880d05340e31186c2460c300b6698dadd4 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sat, 6 Nov 2021 22:29:34 +0000 Subject: [PATCH 453/478] Format Brittany with Brittany --- brittany.yaml | 5 + source/library/Language/Haskell/Brittany.hs | 14 +- .../Language/Haskell/Brittany/Internal.hs | 545 ++++--- .../Haskell/Brittany/Internal/Backend.hs | 540 ++++--- .../Haskell/Brittany/Internal/BackendUtils.hs | 316 ++-- .../Haskell/Brittany/Internal/Config.hs | 275 ++-- .../Haskell/Brittany/Internal/Config/Types.hs | 88 +- .../Internal/Config/Types/Instances.hs | 35 +- .../Brittany/Internal/ExactPrintUtils.hs | 170 +- .../Brittany/Internal/LayouterBasics.hs | 220 ++- .../Brittany/Internal/Layouters/DataDecl.hs | 394 +++-- .../Brittany/Internal/Layouters/Decl.hs | 992 ++++++------ .../Brittany/Internal/Layouters/Expr.hs | 1229 +++++++------- .../Brittany/Internal/Layouters/Expr.hs-boot | 13 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 149 +- .../Brittany/Internal/Layouters/Import.hs | 201 +-- .../Brittany/Internal/Layouters/Module.hs | 128 +- .../Brittany/Internal/Layouters/Pattern.hs | 109 +- .../Brittany/Internal/Layouters/Stmt.hs | 52 +- .../Brittany/Internal/Layouters/Stmt.hs-boot | 11 +- .../Brittany/Internal/Layouters/Type.hs | 448 +++--- .../Haskell/Brittany/Internal/Obfuscation.hs | 30 +- .../Haskell/Brittany/Internal/Prelude.hs | 537 +++---- .../Haskell/Brittany/Internal/PreludeUtils.hs | 26 +- .../Brittany/Internal/Transformations/Alt.hs | 1415 +++++++++-------- .../Internal/Transformations/Columns.hs | 208 +-- .../Internal/Transformations/Floating.hs | 378 ++--- .../Internal/Transformations/Indent.hs | 32 +- .../Brittany/Internal/Transformations/Par.hs | 40 +- .../Haskell/Brittany/Internal/Types.hs | 268 ++-- .../Haskell/Brittany/Internal/Utils.hs | 141 +- .../library/Language/Haskell/Brittany/Main.hs | 296 ++-- source/test-suite/Main.hs | 182 +-- 33 files changed, 4688 insertions(+), 4799 deletions(-) create mode 100644 brittany.yaml diff --git a/brittany.yaml b/brittany.yaml new file mode 100644 index 0000000..fba01fd --- /dev/null +++ b/brittany.yaml @@ -0,0 +1,5 @@ +conf_layout: + lconfig_cols: 79 + lconfig_columnAlignMode: + tag: ColumnAlignModeDisabled + lconfig_indentPolicy: IndentPolicyLeft diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs index 8c225c6..a2726c8 100644 --- a/source/library/Language/Haskell/Brittany.hs +++ b/source/library/Language/Haskell/Brittany.hs @@ -16,13 +16,9 @@ module Language.Haskell.Brittany , CForwardOptions(..) , CPreProcessorConfig(..) , BrittanyError(..) - ) -where + ) where - - - -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 71e885b..f2f0fdc 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -12,68 +12,52 @@ module Language.Haskell.Brittany.Internal , parseModuleFromString , extractCommentConfigs , getTopLevelDeclNameMap - ) -where + ) where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Control.Monad.Trans.Except import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Char (isSpace) +import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TextL -import qualified GHC.OldList as List - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers - -import Control.Monad.Trans.Except -import Data.HList.HList +import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Yaml -import Data.CZipWith -import qualified UI.Butcher.Monadic as Butcher - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.LayouterBasics - -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Indent - -import qualified GHC - hiding ( parseModule ) -import GHC.Parser.Annotation ( AnnKeywordId(..) ) -import GHC ( GenLocated(L) - ) -import GHC.Types.SrcLoc ( SrcSpan ) -import GHC.Hs -import GHC.Data.Bag -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Data.Char ( isSpace ) - - +import qualified GHC hiding (parseModule) +import GHC (GenLocated(L)) +import GHC.Data.Bag +import qualified GHC.Driver.Session as GHC +import GHC.Hs +import qualified GHC.LanguageExtensions.Type as GHC +import qualified GHC.OldList as List +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.SrcLoc (SrcSpan) +import Language.Haskell.Brittany.Internal.Backend +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Transformations.Alt +import Language.Haskell.Brittany.Internal.Transformations.Columns +import Language.Haskell.Brittany.Internal.Transformations.Floating +import Language.Haskell.Brittany.Internal.Transformations.Indent +import Language.Haskell.Brittany.Internal.Transformations.Par +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified UI.Butcher.Monadic as Butcher data InlineConfigTarget = InlineConfigTargetModule @@ -91,35 +75,36 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do [ ( k , [ x | (ExactPrint.Comment x _ _, _) <- - ( ExactPrint.annPriorComments ann + (ExactPrint.annPriorComments ann ++ ExactPrint.annFollowingComments ann ) ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] ) | (k, ann) <- Map.toList anns ] - let configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - ( ("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) + let + configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + (("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) let configParser = Butcher.addAlternatives [ ( "commandline-config" @@ -138,39 +123,44 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do ] parser = do -- we will (mis?)use butcher here to parse the inline config -- line. - let nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + let + nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + let + nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding - let disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let + disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let + disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) + let + disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do @@ -178,41 +168,42 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) Butcher.addNullCmd $ do bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser + conf <- configParser Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) conf <- configParser Butcher.addCmdImpl (InlineConfigTargetModule, conf) lineConfigss <- configLiness `forM` \(k, ss) -> do r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c + Left err -> Left $ (err, s) + Right c -> Right $ c pure (k, r) - let perModule = foldl' - (<>) - mempty - [ conf - | (_ , lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf ) <- lineConfigs - ] + let + perModule = foldl' + (<>) + mempty + [ conf + | (_, lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf) <- lineConfigs + ] let perBinding = Map.fromListWith (<>) [ (n, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs - , n <- case target of + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs + , n <- case target of InlineConfigTargetBinding s -> [s] - InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> - [name] + InlineConfigTargetNextBinding + | Just name <- Map.lookup k declNameMap -> [name] _ -> [] ] let perKey = Map.fromListWith (<>) [ (k, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs , case target of InlineConfigTargetNextDecl -> True InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> @@ -230,7 +221,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls + | decl <- decls , (name : _) <- [getDeclBindingNames decl] ] @@ -248,70 +239,78 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = -- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configWithDebugs inputText = runExceptT $ do - let config = - configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let + config = + configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack (anns, parsedSource, hasCPP) <- do - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let + hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let + hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False parseResult <- lift $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x + Left err -> throwE [ErrorInput err] + Right x -> pure x (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting then do return inputText else do (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack + let + omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConfig perItemConf anns parsedSource else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + let + hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews - , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn - (TextL.pack "\n") - outRaw + , TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw ) else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let + hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack then not $ null errsWarns else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors @@ -331,26 +330,27 @@ pPrintModule -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf inlineConf anns parsedModule = - let ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) + let + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do -- -- debugStrings `forM_` \s -> @@ -365,15 +365,17 @@ pPrintModuleAndCheck -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] + parseResult <- parseModuleFromString + ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let + errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] return (errs', output) @@ -384,18 +386,22 @@ parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of - Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) + Left err -> + return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) Right (anns, parsedModule) -> runExceptT $ do (inlineConf, perItemConf) <- - case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x + case + extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) + of + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let + omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (errs, ltext) <- if omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift @@ -405,13 +411,13 @@ parsePrintModuleTests conf filename input = do else let errStrs = errs <&> \case - ErrorInput str -> str + ErrorInput str -> str ErrorUnusedComment str -> str - LayoutWarning str -> str + LayoutWarning str -> str ErrorUnknownNode str _ -> str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs isErrorUnusedComment :: BrittanyError -> Bool isErrorUnusedComment x = case x of @@ -464,27 +470,30 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do let annKey = ExactPrint.mkAnnKey lmod post <- ppPreamble lmod decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl + let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk - <&> \annMap -> - Map.union (Map.findWithDefault Map.empty annKey annMap) $ - Map.findWithDefault Map.empty declAnnKey annMap + let + mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk <&> \annMap -> + Map.union (Map.findWithDefault Map.empty annKey annMap) + $ Map.findWithDefault Map.empty declAnnKey annMap - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns config <- mAsk - let config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + let + config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) - let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + let + exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do bd <- if exactprintOnly then briDocMToPPM $ briDocByExactNoComment decl @@ -497,33 +506,34 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd - let finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post + let + finalComments = filter + (fst .> \case + ExactPrint.AnnComment{} -> True + _ -> False + ) + post post `forM_` \case (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm - | span <- ExactPrint.commentIdentifier cm - -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + let + folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> + ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] + _ -> [] -- Prints the information associated with the module annotation @@ -540,8 +550,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do -- attached annotations that come after the module's where -- from the module node config <- mAsk - let shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + let + shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack let (filteredAnns', post) = @@ -551,23 +562,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do let modAnnsDp = ExactPrint.annsDP mAnn isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False + isWhere _ = False isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp (pre, post') = case (whereInd, eofInd) of (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in - (filteredAnns'', post') - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations + in (filteredAnns'', post') + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns' if shouldReformatPreamble @@ -576,7 +587,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule return post _sigHead :: Sig GhcPs -> String @@ -589,7 +600,7 @@ _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" @@ -607,63 +618,67 @@ layoutBriDoc briDoc = do transformAlts briDoc >>= mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt -- bridoc transformation: float stuff in mGet >>= transformSimplifyFloating .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating + .> traceIfDumpConf + "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating -- bridoc transformation: par removal mGet >>= transformSimplifyPar .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par -- bridoc transformation: float stuff in mGet >>= transformSimplifyColumns .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns -- bridoc transformation: indent mGet >>= transformSimplifyIndent .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl anns :: ExactPrint.Anns <- mAsk - let state = LayoutState { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } + let + state = LayoutState + { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - let remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] + let + remainingComments = + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs index 142fe2f..0dfa6d6 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -6,10 +6,6 @@ module Language.Haskell.Brittany.Internal.Backend where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.State.Strict as StateS import qualified Data.Either as Either import qualified Data.Foldable as Foldable @@ -21,32 +17,32 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.OldList as List - +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - - -import qualified Data.Text.Lazy.Builder as Text.Builder - - - -type ColIndex = Int +type ColIndex = Int data ColumnSpacing = ColumnSpacingLeaf Int | ColumnSpacingRef Int Int -type ColumnBlock a = [a] +type ColumnBlock a = [a] type ColumnBlocks a = Seq [a] -type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) +type ColMap1 + = IntMapL.IntMap {- ColIndex -} + (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 + = IntMapL.IntMap {- ColIndex -} + (Float, ColumnBlock Int, ColumnBlocks Int) -- (ratio of hasSpace, maximum, raw) data ColInfo @@ -56,20 +52,23 @@ data ColInfo instance Show ColInfo where show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + show (ColInfoNo bd) = + "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") + show (ColInfo ind sig list) = + "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list data ColBuildState = ColBuildState { _cbs_map :: ColMap1 , _cbs_index :: ColIndex } -type LayoutConstraints m = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) +type LayoutConstraints m + = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM = \case @@ -90,10 +89,11 @@ layoutBriDocM = \case BDSeparator -> do layoutAddSepSpace BDAddBaseY indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ layoutBriDocM bd BDBaseYPushCur bd -> do layoutBaseYPushCur @@ -108,36 +108,39 @@ layoutBriDocM = \case layoutBriDocM bd layoutIndentLevelPop BDEnsureIndent indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteEnsureBlock layoutBriDocM bd BDPar indent sameLine indented -> do layoutBriDocM sameLine - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteNewlineBlock layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt:_) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt : _) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd BDExternal annKey subKeys shouldAddComment t -> do - let tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines + let + tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines anns :: ExactPrint.Anns <- mAsk when shouldAddComment $ do layoutWriteAppend - $ Text.pack - $ "{-" + $ Text.pack + $ "{-" ++ show (annKey, Map.lookup annKey anns) ++ "-}" zip [1 ..] tlines `forM_` \(i, l) -> do @@ -154,9 +157,10 @@ layoutBriDocM = \case BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey + let + moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -167,8 +171,8 @@ layoutBriDocM = \case } return mAnn case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace priors @@ -176,9 +180,10 @@ layoutBriDocM = \case when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y @@ -190,18 +195,20 @@ layoutBriDocM = \case layoutBriDocM bd mComments <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let mToSpan = case mAnn of - Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just - annR - _ -> Nothing + let + mToSpan = case mAnn of + Just anns | Maybe.isNothing keyword -> Just anns + Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> + Just annR + _ -> Nothing case mToSpan of Just anns -> do - let (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing + let + (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing mSet $ state { _lstate_comments = Map.adjust (\ann -> ann { ExactPrint.annsDP = rest }) @@ -213,17 +220,19 @@ layoutBriDocM = \case case mComments of Nothing -> pure () Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + -- evil hack for CPP: + case comment of + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd @@ -232,21 +241,26 @@ layoutBriDocM = \case let m = _lstate_comments state pure $ Map.lookup annKey m let mComments = nonEmpty . extractAllComments =<< annMay - let semiCount = length [ () - | Just ann <- [ annMay ] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- mAsk <&> - _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack + let + semiCount = length + [ () + | Just ann <- [annMay] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- + mAsk + <&> _conf_layout + .> _lconfig_experimentalSemicolonNewlines + .> confUnpack mModify $ \state -> state { _lstate_comments = Map.adjust - ( \ann -> ann { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = - flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } + (\ann -> ann + { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } ) annKey (_lstate_comments state) @@ -254,37 +268,40 @@ layoutBriDocM = \case case mComments of Nothing -> do when shouldAddSemicolonNewlines $ do - [1..semiCount] `forM_` const layoutWriteNewline + [1 .. semiCount] `forM_` const layoutWriteNewline Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack comment + case comment of + ('#' : _) -> layoutMoveToCommentPos y (-999) 1 + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let relevant = [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] + let + relevant = + [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] case relevant of [] -> pure Nothing - (ExactPrint.Types.DP (y, x):_) -> do + (ExactPrint.Types.DP (y, x) : _) -> do mSet state { _lstate_commentNewlines = 0 } pure $ Just (y - _lstate_commentNewlines state, x) case mDP of @@ -295,8 +312,8 @@ layoutBriDocM = \case layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" layoutBriDocM bd @@ -307,73 +324,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc -- appended at the current position. where rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc where rec :: BriDoc -> Bool rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_ ] -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= @@ -458,16 +475,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe 0 (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack case () of _ -> do -- tellDebugMess ("processedMap: " ++ show processedMap) sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos <&> processInfo colMax processedMap where (colInfos, finalState) = @@ -484,40 +501,41 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do where alignMax' = max 0 alignMax processedMap :: ColMap2 - processedMap = - fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + processedMap = fix $ \result -> + _cbs_map finalState <&> \(lastFlag, colSpacingss) -> let colss = colSpacingss <&> \spss -> case reverse spss of [] -> [] - (xN:xR) -> - reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR + (xN : xR) -> + reverse + $ (if lastFlag then fLast else fInit) xN + : fmap fInit xR where - fLast (ColumnSpacingLeaf len ) = len + fLast (ColumnSpacingLeaf len) = len fLast (ColumnSpacingRef len _) = len fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of - Nothing -> 0 + fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of + Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} fmap colAggregation $ transpose $ Foldable.toList colss (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols counter count l = if List.last posXs + List.last l <= colMax then count + 1 else count ratio = fromIntegral (foldl counter (0 :: Int) colss) / fromIntegral (length colss) - in - (ratio, maxCols, colss) + in (ratio, maxCols, colss) mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd:bdr) = do - info <- mergeInfoBriDoc True lastInfo bd + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd : bdr) = do + info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info) @@ -545,28 +563,27 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- personal preference to not break alignment for those, even if -- multiline. Really, this should be configurable.. (TODO) shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = alignBreak && - briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True + shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp{} _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True mergeInfoBriDoc :: Bool @@ -574,23 +591,22 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -> BriDoc -> StateS.StateT ColBuildState Identity ColInfo mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs - -> do + | infoSig == colSig && length subLengthsInfos == length subDocs -> do let isLastList = if lastFlag - then (==length subDocs) <$> [1 ..] + then (== length subDocs) <$> [1 ..] else repeat False infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs + let curLengths = briDocLineLength <$> subDocs let trueSpacings = getTrueSpacings (zip curLengths infos) do -- update map s <- StateS.get - let m = _cbs_map s + let m = _cbs_map s let (Just (_, spaces)) = IntMapS.lookup infoInd m StateS.put s { _cbs_map = IntMapS.insert @@ -599,17 +615,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do m } return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise - -> briDocToColInfo lastFlag brdc + | otherwise -> briDocToColInfo lastFlag brdc brdc -> return $ ColInfoNo brdc briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo lastFlag = \case BDCols sig list -> withAlloc lastFlag $ \ind -> do - let isLastList = - if lastFlag then (==length list) <$> [1 ..] else repeat False + let + isLastList = + if lastFlag then (== length list) <$> [1 ..] else repeat False subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos + let lengthInfos = zip (briDocLineLength <$> list) subInfos let trueSpacings = getTrueSpacings lengthInfos return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) bd -> return $ ColInfoNo bd @@ -617,11 +633,11 @@ briDocToColInfo lastFlag = \case getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings lengthInfos = lengthInfos <&> \case (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _ ) -> ColumnSpacingLeaf len + (len, _) -> ColumnSpacingLeaf len withAlloc :: Bool - -> ( ColIndex + -> ( ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) ) -> StateS.State ColBuildState ColInfo @@ -636,13 +652,14 @@ withAlloc lastFlag f = do processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ do colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do + alignMode <- + mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack + curX <- do state <- mGet -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state @@ -654,10 +671,11 @@ processInfo maxSpace m = \case let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l + let + maxCols2 = list <&> \case + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l let maxCols = zipWith max maxCols1 maxCols2 let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols -- handle the cases that the vertical alignment leads to more than max @@ -668,46 +686,48 @@ processInfo maxSpace m = \case -- sizes in such a way that it works _if_ we have sizes (*factor) -- in each column. but in that line, in the last column, we will be -- forced to occupy the full vertical space, not reduced by any factor. - let fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (*factor) .> truncate - _ -> posXs - let spacings = zipWith (-) - (List.tail fixedPosXs ++ [min maxX colMax]) - fixedPosXs + let + fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (* factor) .> truncate + _ -> posXs + let + spacings = + zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs -- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct + let + alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. + then noAlignAct + else alignAct case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct processInfoIgnore :: LayoutConstraints m => ColInfo -> m () processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index 6c34ea9..e48da84 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -3,42 +3,29 @@ module Language.Haskell.Brittany.Internal.BackendUtils where - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Either import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey - , Annotation - ) - import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (Located) +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.Brittany.Internal.Utils -import GHC ( Located ) - - - -traceLocal - :: (MonadMultiState LayoutState m) - => a - -> m () +traceLocal :: (MonadMultiState LayoutState m) => a -> m () traceLocal _ = return () layoutWriteAppend - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Text -> m () layoutWriteAppend t = do @@ -54,15 +41,13 @@ layoutWriteAppend t = do mTell $ Text.Builder.fromText $ t mModify $ \s -> s { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces , _lstate_addSepSpace = Nothing } layoutWriteAppendSpaces - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () layoutWriteAppendSpaces i = do @@ -70,20 +55,18 @@ layoutWriteAppendSpaces i = do unless (i == 0) $ do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state + { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state } layoutWriteAppendMultiline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => [Text] -> m () layoutWriteAppendMultiline ts = do traceLocal ("layoutWriteAppendMultiline", ts) case ts of - [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. - (l:lr) -> do + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. + (l : lr) -> do layoutWriteAppend l lr `forM_` \x -> do layoutWriteNewline @@ -91,16 +74,15 @@ layoutWriteAppendMultiline ts = do -- adds a newline and adds spaces to reach the base column. layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteNewlineBlock = do traceLocal ("layoutWriteNewlineBlock") state <- mGet - mSet $ state { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - } + mSet $ state + { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + } -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- , MonadMultiWriter (Seq String) m) => Int -> m () @@ -116,13 +98,13 @@ layoutWriteNewlineBlock = do -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } -layoutSetCommentCol - :: (MonadMultiState LayoutState m) => m () +layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol = do state <- mGet - let col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + let + col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state traceLocal ("layoutSetCommentCol", col) unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } @@ -130,9 +112,7 @@ layoutSetCommentCol = do -- This is also used to move to non-comments in a couple of places. Seems -- to be harmless so far.. layoutMoveToCommentPos - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> Int -> Int @@ -142,38 +122,35 @@ layoutMoveToCommentPos y x commentLines = do state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y + Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = + , _lstate_addSepSpace = Just $ if Data.Maybe.isJust (_lstate_commentCol state) then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = - Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_commentCol = Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 + _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteNewline = do traceLocal ("layoutWriteNewline") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing + , _lstate_addSepSpace = Nothing } _layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () @@ -181,77 +158,67 @@ _layoutResetCommentNewlines = do mModify $ \state -> state { _lstate_commentNewlines = 0 } layoutWriteEnsureNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteEnsureNewlineBlock = do traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing } layoutWriteEnsureAbsoluteN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c , _ ) -> n - c - (Nothing, Left i ) -> n - i - (Nothing, Right{}) -> n + let + diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c, _) -> n - c + (Nothing, Left i) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to + mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to -- at least (Just 1), so we won't -- overwrite any old value in any -- bad way. - } -layoutBaseYPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () +layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m () layoutBaseYPushInternal i = do traceLocal ("layoutBaseYPushInternal", i) mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } -layoutBaseYPopInternal - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal = do traceLocal ("layoutBaseYPopInternal") mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () + :: (MonadMultiState LayoutState m) => Int -> m () layoutIndentLevelPushInternal i = do traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } -layoutIndentLevelPopInternal - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal = do traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } -layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () +layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger = do - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } layoutWithAddBaseCol :: ( MonadMultiWriter Text.Builder.Builder m @@ -283,9 +250,7 @@ layoutWithAddBaseColBlock m = do layoutBaseYPopInternal layoutWithAddBaseColNBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () -> m () @@ -298,27 +263,23 @@ layoutWithAddBaseColNBlock amount m = do layoutBaseYPopInternal layoutWriteEnsureBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteEnsureBlock = do traceLocal ("layoutWriteEnsureBlock") state <- mGet let diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i ) -> lstate_baseY state - i + (Nothing, Left i) -> lstate_baseY state - i (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i ) -> max sp (lstate_baseY state - i) + (Just sp, Left i) -> max sp (lstate_baseY state - i) (Just sp, Right{}) -> max sp (lstate_baseY state) -- when (diff>0) $ layoutWriteNewlineBlock when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just $ diff } layoutWithAddBaseColN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () -> m () @@ -328,39 +289,36 @@ layoutWithAddBaseColN amount m = do m layoutBaseYPopInternal -layoutBaseYPushCur - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur = do traceLocal ("layoutBaseYPushCur") state <- mGet case _lstate_commentCol state of Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> layoutBaseYPushInternal (i + j) - (Left i , Nothing) -> layoutBaseYPushInternal i - (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state + (Left i, Just j) -> layoutBaseYPushInternal (i + j) + (Left i, Nothing) -> layoutBaseYPushInternal i + (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state Just cCol -> layoutBaseYPushInternal cCol -layoutBaseYPop - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPop :: (MonadMultiState LayoutState m) => m () layoutBaseYPop = do traceLocal ("layoutBaseYPop") layoutBaseYPopInternal -layoutIndentLevelPushCur - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur = do traceLocal ("layoutIndentLevelPushCur") state <- mGet - let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> i + j - (Left i , Nothing) -> i - (Right{}, Just j ) -> j - (Right{}, Nothing) -> 0 + let + y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> i + j + (Left i, Nothing) -> i + (Right{}, Just j) -> j + (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y -layoutIndentLevelPop - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") layoutIndentLevelPopInternal @@ -370,12 +328,12 @@ layoutIndentLevelPop = do -- make sense. layoutRemoveIndentLevelLinger -layoutAddSepSpace :: (MonadMultiState LayoutState m) - => m () +layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () layoutAddSepSpace = do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state + } -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. @@ -390,7 +348,7 @@ moveToExactAnn annKey = do traceLocal ("moveToExactAnn", annKey) anns <- mAsk case Map.lookup annKey anns of - Nothing -> return () + Nothing -> return () Just ann -> do -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann @@ -399,19 +357,19 @@ moveToExactAnn annKey = do moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY y = mModify $ \state -> - let upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then - _lstate_commentCol state - <|> _lstate_addSepSpace state - <|> Just (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } + let + upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in + state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just + (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do @@ -421,9 +379,7 @@ moveToY y = mModify $ \state -> -- else x ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m - => ExactPrint.DeltaPos - -> m () + :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ y $ mTell $ Text.Builder.fromString " " @@ -439,75 +395,77 @@ layoutWritePriorComments layoutWritePriorComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annPriorComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just priors -> do unless (null priors) $ layoutSetCommentCol - priors `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment + priors + `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. -- per documentation, this seems sufficient, as the -- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Located ast -> m () +layoutWritePostComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Located ast + -> m () layoutWritePostComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just posts -> do unless (null posts) $ layoutSetCommentCol - posts `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment + posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> + do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment - :: ( MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - ) + :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) => m () layoutIndentRestorePostComment = do state <- mGet let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state - mModify $ \s -> s { _lstate_commentCol = Nothing - , _lstate_commentNewlines = 0 - } + let eCurYAddNL = _lstate_curYOrAddNewline state + mModify + $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) - _ -> return () + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe + 0 + (_lstate_addSepSpace state) + _ -> return () -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs index 66d6d7f..b951db9 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -3,185 +3,174 @@ module Language.Haskell.Brittany.Internal.Config where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Bool as Bool import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Coerce (coerce) +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Semigroup as Semigroup -import qualified GHC.OldList as List -import qualified System.Directory -import qualified System.IO - import qualified Data.Yaml -import Data.CZipWith +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config.Types.Instances () +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Utils +import qualified System.Console.CmdArgs.Explicit as CmdArgs +import qualified System.Directory +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import UI.Butcher.Monadic -import UI.Butcher.Monadic - -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 ( coerce - ) -import qualified Data.List.NonEmpty as NonEmpty - -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] } --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } +-- brittany-next-binding --columns 200 cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") - dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") - dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") - dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") - dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") - dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") - dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = mempty } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Bool.bool Nothing (Just True) @@ -228,8 +217,8 @@ readConfig path = do fileConf <- case Data.Yaml.decodeEither' contents of Left e -> do liftIO - $ putStrErrLn - $ "error reading in brittany config from " + $ putStrErrLn + $ "error reading in brittany config from " ++ path ++ ":" liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) @@ -243,11 +232,12 @@ readConfig path = do userConfigPath :: IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith Directory.doesFileExist - searchDirs - "config.yaml" + globalConfig <- Directory.findFileWith + Directory.doesFileExist + searchDirs + "config.yaml" maybe (writeUserConfig userBritPathXdg) pure globalConfig where writeUserConfig dir = do @@ -259,7 +249,7 @@ userConfigPath = do -- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir + let dirParts = FilePath.splitDirectories dir -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" @@ -271,8 +261,9 @@ readConfigs -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let merged = Semigroup.sconcat - $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + let + merged = + Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 929ac90..0b81ae6 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -7,63 +7,54 @@ module Language.Haskell.Brittany.Internal.Config.Types where - - +import Data.CZipWith +import Data.Coerce (Coercible, coerce) +import Data.Data (Data) +import qualified Data.Semigroup as Semigroup +import Data.Semigroup (Last) +import Data.Semigroup.Generic +import GHC.Generics import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils () -import qualified Data.Semigroup as Semigroup - -import GHC.Generics - -import Data.Data ( Data ) - -import Data.Coerce ( Coercible, coerce ) - -import Data.Semigroup.Generic -import Data.Semigroup ( Last ) - -import Data.CZipWith - - confUnpack :: Coercible a b => Identity a -> b confUnpack (Identity x) = coerce x data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. , _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentAmount :: f (Last Int) , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) + , _lconfig_importColumn :: f (Last Int) -- ^ for import statement layouting, column at which to align the -- elements to be imported from a module. -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) + , _lconfig_importAsColumn :: f (Last Int) -- ^ for import statement layouting, column at which put the module's -- "as" name (which also affects the positioning of the "as" keyword). -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) + , _lconfig_alignmentLimit :: f (Last Int) -- roughly speaking, this sets an upper bound to the number of spaces -- inserted to create horizontal alignment. -- More specifically, if 'xs' are the widths of the columns in some @@ -148,17 +139,17 @@ data CLayoutConfig f = LayoutConfig -- -- > , y :: Double -- -- > } } - deriving (Generic) + deriving Generic data CForwardOptions f = ForwardOptions { _options_ghc :: f [String] } - deriving (Generic) + deriving Generic data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) -- ^ Determines when to fall back on the exactprint'ed output when -- syntactical constructs are encountered which are not yet handled by -- brittany. @@ -168,21 +159,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig -- has different semantics than the code pre-transformation. , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CPreProcessorConfig f = PreProcessorConfig { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config @@ -193,10 +184,9 @@ data CConfig f = Config -- module. Useful for wildcard application -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) - + , _conf_obfuscate :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic type DebugConfig = CDebugConfig Identity type LayoutConfig = CLayoutConfig Identity diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 2c0c78f..be7a0bb 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -18,22 +18,16 @@ module Language.Haskell.Brittany.Internal.Config.Types.Instances where - - -import Language.Haskell.Brittany.Internal.Prelude - -import Data.Yaml import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson - +import Data.Yaml import Language.Haskell.Brittany.Internal.Config.Types - - +import Language.Haskell.Brittany.Internal.Prelude aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany = Aeson.defaultOptions { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (=='_') + , Aeson.fieldLabelModifier = dropWhile (== '_') } instance FromJSON (CDebugConfig Maybe) where @@ -108,17 +102,18 @@ instance ToJSON (CConfig Maybe) where -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- config file content. instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = Config - <$> v .:? Key.fromString "conf_version" - <*> v .:?= Key.fromString "conf_debug" - <*> v .:?= Key.fromString "conf_layout" - <*> v .:?= Key.fromString "conf_errorHandling" - <*> v .:?= Key.fromString "conf_forward" - <*> v .:?= Key.fromString "conf_preprocessor" - <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" - <*> v .:? Key.fromString "conf_disable_formatting" - <*> v .:? Key.fromString "conf_obfuscate" - parseJSON invalid = Aeson.typeMismatch "Config" invalid + parseJSON (Object v) = + Config + <$> (v .:? Key.fromString "conf_version") + <*> (v .:?= Key.fromString "conf_debug") + <*> (v .:?= Key.fromString "conf_layout") + <*> (v .:?= Key.fromString "conf_errorHandling") + <*> (v .:?= Key.fromString "conf_forward") + <*> (v .:?= Key.fromString "conf_preprocessor") + <*> (v .:? Key.fromString "conf_roundtrip_exactprint_only") + <*> (v .:? Key.fromString "conf_disable_formatting") + <*> (v .:? Key.fromString "conf_obfuscate") + parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 46e1b6a..5020745 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -7,47 +7,34 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Control.Exception import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.Data import qualified Data.Foldable as Foldable +import qualified Data.Generics as SYB +import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Set as Set -import qualified System.IO - -import Language.Haskell.Brittany.Internal.Config.Types -import Data.Data -import Data.HList.HList - -import GHC ( GenLocated(L) ) -import qualified GHC.Driver.Session as GHC +import GHC (GenLocated(L)) import qualified GHC hiding (parseModule) -import qualified GHC.Types.SrcLoc as GHC +import GHC.Data.Bag import qualified GHC.Driver.CmdLine as GHC - -import GHC.Hs -import GHC.Data.Bag - -import GHC.Types.SrcLoc ( SrcSpan, Located ) - - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint - -import qualified Data.Generics as SYB - -import Control.Exception --- import Data.Generics.Schemes - - +import qualified GHC.Driver.Session as GHC +import GHC.Hs +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.SrcLoc (Located, SrcSpan) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified System.IO parseModule :: [String] @@ -67,7 +54,7 @@ parseModuleWithCpp -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleWithCpp cpp opts args fp dynCheck = ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ GHC.getSessionDynFlags + dflags0 <- lift $ GHC.getSessionDynFlags (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> ("-hide-all-packages" : args)) @@ -79,17 +66,20 @@ parseModuleWithCpp cpp opts args fp dynCheck = void $ lift $ GHC.setSessionDynFlags dflags1 dflags2 <- lift $ ExactPrint.initDynFlags fp unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " + $ ExceptT.throwE + $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " + $ ExceptT.throwE + $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) - x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 + x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp - either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) - (\(a, m) -> pure (a, m, x)) + either + (\err -> ExceptT.throwE $ "transform error: " ++ show + (bagToList (show <$> err)) + ) + (\(a, m) -> pure (a, m, x)) $ ExactPrint.postParseTransform res opts parseModuleFromString @@ -107,46 +97,51 @@ parseModuleFromString args fp dynCheck str = -- bridoc transformation stuff. -- (reminder to update note on `parsePrintModule` if this changes.) mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str + dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " + $ ExceptT.throwE + $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " + $ ExceptT.throwE + $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of - Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) - Right (a , m ) -> pure (a, m, dynCheckRes) + Left err -> + ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) + Right (a, m) -> pure (a, m, dynCheckRes) commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob ast = do - let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` - (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) + let + extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` (\l@(L span _) -> + Seq.singleton (span, ExactPrint.mkAnnKey l) + ) let nodes = SYB.everything (<>) extract ast - let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] + let + annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (const id) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes + ] nodes `forM_` (snd .> processComs annsMap) where processComs annsMap annKey1 = do mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn `forM_` \ann1 -> do - let priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 + let + priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 let processCom :: (ExactPrint.Comment, ExactPrint.DeltaPos) @@ -158,31 +153,32 @@ commentAnnFixTransformGlob ast = do (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> move $> False (x, y) | x == y -> move $> False - _ -> return True + _ -> return True where ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 move = ExactPrint.modifyAnnsT $ \anns -> let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2' = ann2 { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] + ExactPrint.annFollowingComments ann2 ++ [comPair] } - in - Map.insert annKey2 ann2' anns + in Map.insert annKey2 ann2' anns _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors + priors' <- filterM processCom priors follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case + assocs' <- flip filterM assocs $ \case (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let ann1' = ann1 { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } + _ -> return True + let + ann1' = ann1 + { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns @@ -270,29 +266,30 @@ extractToplevelAnns lmod anns = output | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns ] declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + 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 +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 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 + (\x -> maybe Set.empty Set.singleton [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x + ] -- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- even though it is passed to mkAnnKey above, which only accepts -- SrcSpan. - ] ) ast where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) @@ -301,8 +298,8 @@ foldedAnnKeys ast = SYB.everything withTransformedAnns :: Data ast => ast - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case readers@(conf :+: anns :+: HNil) -> do -- TODO: implement `local` for MultiReader/MultiRWS @@ -312,9 +309,10 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case pure x where f anns = - let ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced + let + ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced warnExtractorCompat :: GHC.Warn -> String diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 422c7be..8f861d4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -6,50 +6,37 @@ module Language.Haskell.Brittany.Internal.LayouterBasics where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Writer.Strict as Writer +import qualified Data.Char as Char +import Data.Data import qualified Data.Map as Map import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import DataTreePrint +import GHC (GenLocated(L), Located, moduleName, moduleNameString) import qualified GHC.OldList as List - -import qualified Control.Monad.Writer.Strict as Writer - +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.Name (getOccString) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName(..)) +import qualified GHC.Types.SrcLoc as GHC +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import GHC.Types.Name.Reader ( RdrName(..) ) -import GHC ( Located, GenLocated(L), moduleName, moduleNameString ) -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.Name.Occurrence ( occNameString ) -import GHC.Types.Name ( getOccString ) -import GHC.Parser.Annotation ( AnnKeywordId(..) ) - -import Data.Data - -import qualified Data.Char as Char - -import DataTreePrint - - - processDefault :: ( ExactPrint.Annotate.Annotate ast , MonadMultiWriter Text.Builder.Builder m @@ -67,7 +54,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString str + _ -> mTell $ Text.Builder.fromString str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -79,9 +66,10 @@ briDocByExact -> ToBriDocM BriDocNumbered briDocByExact ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns True -- | Use ExactPrint's output for this node. @@ -95,9 +83,10 @@ briDocByExactNoComment -> ToBriDocM BriDocNumbered briDocByExactNoComment ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns False -- | Use ExactPrint's output for this node, presuming that this output does @@ -110,24 +99,26 @@ briDocByExactInlineOnly -> ToBriDocM BriDocNumbered briDocByExactInlineOnly infoStr ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t - let errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit - $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + let + exactPrintNode t = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + t + let + errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _ ) -> errorAction - (_ , [t]) -> exactPrintNode + (ExactPrintFallbackModeNever, _) -> errorAction + (_, [t]) -> exactPrintNode (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted _ -> errorAction @@ -152,20 +143,21 @@ lrdrNameToTextAnnGen lrdrNameToTextAnnGen f ast@(L _ n) = do anns <- mAsk let t = f $ rdrNameToText n - let hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False + let + hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. -- whatever we don't probably should have had some effect on the -- output. in such cases, resorting to byExact is probably the safe -- choice. return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t + Nothing -> t Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t lrdrNameToTextAnn :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) @@ -178,9 +170,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial => Located RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + let + f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x lrdrNameToTextAnnGen f ast -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects @@ -198,10 +191,11 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick -> m Text lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + x <- lrdrNameToTextAnn ast2 + let + lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x return $ if hasQuote then Text.cons '\'' lit else lit askIndent :: (MonadMultiReader Config m) => m Int @@ -219,12 +213,11 @@ extractRestComments ann = ExactPrint.annFollowingComments ann ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] + _ -> [] ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) -- | True if there are any comments that are -- a) connected to any node below (in AST sense) the given node AND @@ -242,15 +235,16 @@ hasCommentsBetween -> ToBriDocM Bool hasCommentsBetween ast leftKey rightKey = do mAnn <- astAnn ast - let go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest + let + go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest case mAnn of - Nothing -> pure False + Nothing -> pure False Just ann -> pure $ go1 $ ExactPrint.annsDP ann -- | True if there are any comments that are connected to any node below (in AST @@ -260,7 +254,8 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast -- | True if there are any regular comments connected to any node below (in AST -- sense) the given node -hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected + :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyRegularCommentsConnected ast = any isRegularComment <$> astConnectedComments ast @@ -297,7 +292,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False + Nothing -> False Just ann -> any hasK (extractAllComments ann) where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst @@ -311,7 +306,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks where hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False + hasK _ = False astAnn :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) @@ -460,12 +455,10 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) deriving (Functor, Applicative, Monad) addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = - when cond (addAlternative doc) +addAlternativeCond cond doc = when cond (addAlternative doc) addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = - CollectAltM . Writer.tell . (: []) +addAlternative = CollectAltM . Writer.tell . (: []) runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative (CollectAltM action) = @@ -482,7 +475,8 @@ docLines l = allocateNode . BDFLines =<< sequence l docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docCols sig l = allocateNode . BDFCols sig =<< sequence l -docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAddBaseY + :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -517,7 +511,8 @@ docAnnotationKW -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm +docAnnotationKW annKey kw bdm = + allocateNode . BDFAnnotationKW annKey kw =<< bdm docMoveToKWDP :: AnnKey @@ -569,7 +564,7 @@ docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] docParenHashRSep :: ToBriDocM BriDocNumbered docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] @@ -631,32 +626,26 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNodePrior ast bdm = do bd <- bdm i1 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ bd + return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd docWrapNodeRest ast bdm = do bd <- bdm i2 <- allocNodeIndex - return - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd + return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where docWrapNode ast bdms = case bdms of [] -> [] [bd] -> [docWrapNode ast bd] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdms = case bdms of [] -> [] [bd] -> [docWrapNodePrior ast bd] - (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR + (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + [] -> [] + (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do @@ -666,25 +655,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ [bd1'] ++ reverse bdM ++ [bdN'] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdsm = do bds <- bdsm case bds of [] -> return [] - (bd1:bdR) -> do + (bd1 : bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return (bd1':bdR) + return (bd1' : bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of [] -> return [] - (bdN:bdR) -> do + (bdN : bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN':bdR) + return $ reverse (bdN' : bdR) instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do @@ -697,7 +686,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where return $ Seq.singleton bd1' bdM Seq.:> bdN -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ (bd1' Seq.<| bdM) Seq.|> bdN' docWrapNodePrior ast bdsm = do bds <- bdsm @@ -741,7 +730,7 @@ docPar -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docPar lineM indentedM = do - line <- lineM + line <- lineM indented <- indentedM allocateNode $ BDFPar BrIndentNone line indented @@ -778,14 +767,15 @@ briDocMToPPM m = do briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR - let ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m + let + ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index acbe186..3bafd56 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -3,26 +3,19 @@ module Language.Haskell.Brittany.Internal.Layouters.DataDecl where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( Located, GenLocated(L) ) +import GHC (GenLocated(L), Located) import qualified GHC -import GHC.Hs - -import Language.Haskell.Brittany.Internal.Layouters.Type - - +import GHC.Hs +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types layoutDataDecl :: Located (TyClDecl GhcPs) @@ -32,28 +25,29 @@ layoutDataDecl -> ToBriDocM BriDocNumbered layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> - docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) + -> docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl -- data MyData a b @@ -61,8 +55,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "data" , lhsContextDoc @@ -74,32 +68,36 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- data MyData = MyData { .. } HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> - docWrapNode ltycl $ do + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) + -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing + Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- return <$> createDetailsDoc consNameStr details - consDoc <- fmap pure + rhsDoc <- return <$> createDetailsDoc consNameStr details + consDoc <- + fmap pure $ docNonBottomSpacing $ case (forallDocMay, rhsContextDocMay) of (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [ docLitS "." , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + , docSetBaseY + $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] ] (Just forallDoc, Nothing) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [docLitS ".", docSeparator, rhsDoc] ] (Nothing, Just rhsContextDoc) -> docSeq @@ -107,12 +105,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSeparator , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] - (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] + (Nothing, Nothing) -> + docSeq [docLitS "=", docSeparator, rhsDoc] createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline $ lhsContextDoc , appSep $ docLit nameStr @@ -124,12 +122,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -137,26 +136,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr , tyVarLine ] ) - ( docSeq + (docSeq [ docLitS "=" , docSeparator , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -167,8 +166,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -189,13 +187,10 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- hurt. docAddBaseY BrIndentRegular $ docPar (docLitS "data") - ( docLines + (docLines [ lhsContextDoc , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLit nameStr - , tyVarLine - ] + $ docSeq [appSep $ docLit nameStr, tyVarLine] , consDoc ] ) @@ -209,20 +204,20 @@ createContextDoc [] = docEmpty createContextDoc [t] = docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 + t1Doc <- docSharedWrapper layoutType t1 tRDocs <- tR `forM` docSharedWrapper layoutType docAlt [ docSeq [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse docCommaSep - (t1Doc : tRDocs) + , docForceSingleline $ docSeq $ List.intersperse + docCommaSep + (t1Doc : tRDocs) , docLitS ") =>" , docSeparator ] , docLines $ join [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs - <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] , [docLitS ") =>", docSeparator] ] ] @@ -234,20 +229,18 @@ createBndrDoc bs = do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) - docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] + docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> + case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -256,48 +249,47 @@ createDerivingPar derivs mainDoc = do (L _ []) -> mainDoc (L _ types) -> docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of - (L _ []) -> docSeq [] - (L _ ts) -> - let - tsLength = length ts - whenMoreThan1Type val = - if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in - docSeq +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = + case types of + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = + if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = + maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in docSeq [ docDeriving , docWrapNodePrior types $ lhsStrategy , docSeparator , whenMoreThan1Type "(" , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts <&> \case - HsIB _ t -> layoutType t + $ docSeq + $ List.intersperse docCommaSep + $ ts + <&> \case + HsIB _ t -> layoutType t , whenMoreThan1Type ")" , rhsStrategy ] where strategyLeftRight = \case - (L _ StockStrategy ) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes) ) -> + (L _ StockStrategy) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) + lVia@(L _ (ViaStrategy viaTypes)) -> ( docEmpty , case viaTypes of - HsIB _ext t -> docSeq - [ docWrapNode lVia $ docLitS " via" - , docSeparator - , layoutType t - ] + HsIB _ext t -> docSeq + [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] ) docDeriving :: ToBriDocM BriDocNumbered @@ -307,21 +299,25 @@ createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- + mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq [ docLit consNameStr , docSeparator , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ fmap hsScaledThing args <&> layoutType + $ docSeq + $ List.intersperse docSeparator + $ fmap hsScaledThing args + <&> layoutType ] - leftIndented = docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType <$> fmap hsScaledThing args + leftIndented = + docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType + <$> fmap hsScaledThing args multiAppended = docSeq [ docLit consNameStr , docSeparator @@ -331,79 +327,80 @@ createDetailsDoc consNameStr details = case details of (docLit consNameStr) (docLines $ layoutType <$> fmap hsScaledThing args) case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyFree -> docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_:_)) -> do + RecCon (L _ []) -> + docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_ : _)) -> do let ((fName1, fType1) : fDocR) = mkFieldDocs fields -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False - docAddBaseY BrIndentRegular - $ runFilteredAlternative - $ do + docAddBaseY BrIndentRegular $ runFilteredAlternative $ do -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols + ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols + ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 + , docForceSingleline fType ] , docSeq - [ docLitS "{" + [ docLitS "," , docSeparator , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) + fName + (docSeq [docLitS "::", docSeparator, fType]) ] ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType - ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] - , docLitS "}" - ] - ) + , docLitS "}" + ] + ) InfixCon arg1 arg2 -> docSeq [ layoutType $ hsScaledThing arg1 , docSeparator @@ -418,10 +415,11 @@ createDetailsDoc consNameStr details = case details of mkFieldDocs = fmap $ \lField -> case lField of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t -createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = Just $ docSeq - [docLitS "forall ", createBndrDoc lhsTyVarBndrs] +createForallDoc + :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = + Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc :: Data.Data.Data ast @@ -431,12 +429,8 @@ createNamesAndTypeDoc -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \case - L _ (FieldOcc _ fieldName) -> - docLit =<< lrdrNameToTextAnn fieldName + [ docSeq $ List.intersperse docCommaSep $ names <&> \case + L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName ] , docWrapNodeRest lField $ layoutType t ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index a96ae47..c2ff209 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -5,56 +5,46 @@ module Language.Haskell.Brittany.Internal.Layouters.Decl where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Foldable import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Layouters.Type - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import GHC ( GenLocated(L) - , AnnKeywordId(..) - ) -import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc ) +import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC.Data.Bag (bagToList, emptyBag) import qualified GHC.Data.FastString as FastString -import GHC.Hs -import GHC.Types.Basic ( InlinePragma(..) - , Activation(..) - , InlineSpec(..) - , RuleMatchInfo(..) - , LexicalFixity(..) - ) -import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) - +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic + ( Activation(..) + , InlinePragma(..) + , InlineSpec(..) + , LexicalFixity(..) + , RuleMatchInfo(..) + ) +import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Pattern import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.DataDecl - -import GHC.Data.Bag ( bagToList, emptyBag ) - - +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint layoutDecl :: ToBriDoc HsDecl layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> @@ -67,52 +57,61 @@ layoutDecl d@(L loc decl) = case decl of layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> + layoutNamesAndType Nothing names typ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " + let + phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let + conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ + ClassOpSig _ False names (HsIB _ typ) -> + layoutNamesAndType Nothing names typ + PatSynSig _ names (HsIB _ typ) -> + layoutNamesAndType (Just "pattern") names typ _ -> briDocByExactNoComment lsig -- TODO where layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] + let + keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- mAsk - <&> _conf_layout - .> _lconfig_hangingTypeSignature - .> confUnpack + shouldBeHanging <- + mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging - then docSeq $ - [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc + then + docSeq + $ [ appSep + $ docWrapNodeRest lsig + $ docSeq + $ keyDoc + <> [docLit nameStr] + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ] ] - ] - ] else layoutLhsAndType hasComments (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) @@ -122,22 +121,23 @@ layoutSig lsig@(L _loc sig) = case sig of specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body + BodyStmt _ body _ _ -> layoutExpr body BindStmt _ lPat expr -> do patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr - docCols ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO + docCols + ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- @@ -145,37 +145,33 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -------------------------------------------------------------------------------- layoutBind - :: ToBriDocC - (HsBindLR GhcPs GhcPs) - (Either [BriDocNumbered] BriDocNumbered) + :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" funcPatDocs <- docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches return $ Left $ funcPatDocs PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat + patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" + binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal + Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereArg + hasComments PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID - lpat - dir - rpat + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of @@ -185,7 +181,13 @@ layoutIPBind lipbind@(L _ bind) = case bind of binderDoc <- docLit $ Text.pack "=" exprDoc <- layoutExpr expr hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments + layoutPatternBindFinal + Nothing + binderDoc + (Just ipName) + [([], exprDoc, expr)] + Nothing + hasComments data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) @@ -193,7 +195,7 @@ data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) @@ -203,18 +205,18 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + let + unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s + BagSig s -> return <$> layoutSig s return $ Just $ docs -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> - Just <$> mapM layoutIPBind bb + HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is @@ -224,7 +226,7 @@ layoutGrhs -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body + bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) layoutPatternBind @@ -233,7 +235,7 @@ layoutPatternBind -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match + let pats = m_pats match let (GRHSs _ grhss whereBinds) = m_grhss match patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match @@ -242,25 +244,26 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1:p2:pr) | isInfix -> if null pr - then - docCols ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else - docCols ColPatternsFuncInfix - ( [docCols ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR - ] + (Just idStr, p1 : p2 : pr) | isInfix -> if null pr + then docCols + ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else docCols + ColPatternsFuncInfix + ([ docCols + ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) + ] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix @@ -274,30 +277,30 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments + layoutPatternBindFinal + alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereArg + hasComments -fixPatternBindIdentifier - :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match where go = \case - (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr + (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1 ) -> goInner ctx1 - _ -> idStr + (StmtCtxt ctx1) -> goInner ctx1 + _ -> idStr -- I have really no idea if this path ever occurs, but better safe than -- risking another "drop bangpatterns" bugs. goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr + _ -> idStr layoutPatternBindFinal :: Maybe Text @@ -308,304 +311,304 @@ layoutPatternBindFinal -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do - let patPartInline = case mPatDoc of - Nothing -> [] +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments + = do + let + patPartInline = case mPatDoc of + Nothing -> [] Just patDoc -> [appSep $ docForceSingleline $ return patDoc] patPartParWrap = case mPatDoc of - Nothing -> id + Nothing -> id Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- mAsk - <&> _conf_layout - .> _lconfig_indentWhereSpecial - .> confUnpack - regularIndentAmount <- mAsk - <&> _conf_layout - .> _lconfig_indentAmount - .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt - [ docEnsureIndent BrIndentRegular - $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False + whereIndent <- do + shouldSpecial <- + mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack + regularIndentAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + [ docEnsureIndent BrIndentRegular $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docMoveToKWDP annKeyWhere AnnWhere False $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty + ] + ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let + singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse docCommaSep - (docForceSingleline . return <$> gs) + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + gs -> + docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ (List.intersperse + docCommaSep + (docForceSingleline . return <$> gs) ) wherePart = case mWhereDocs of - Nothing -> Just docEmpty + Nothing -> Just docEmpty Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] - _ -> Nothing + _ -> Nothing - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack + indentPolicy <- + mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - runFilteredAlternative $ do + runFilteredAlternative $ do - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' + ] ] - ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1:gr) -> - ( docSeq [appSep $ docLit $ Text.pack "|", return g1] - : ( gr - <&> \g -> - docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline $ docSeq + [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline $ docSeq + [appSep $ docLit $ Text.pack "|", return g] ] - ] - ] - ++ wherePartMultiLine + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1 : gr) -> + (docSeq [appSep $ docLit $ Text.pack "|", return g1] + : (gr + <&> \g -> docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine -- | Layout a pattern synonym binding layoutPatSynBind @@ -615,44 +618,51 @@ layoutPatSynBind -> LPat GhcPs -> ToBriDocM BriDocNumbered layoutPatSynBind name patSynDetails patDir rpat = do - let patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" + let + patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir - headDoc <- fmap pure $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] + headDoc <- + fmap pure + $ docSeq + $ [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] runFilteredAlternative $ do - addAlternative $ + addAlternative + $ -- pattern .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docSeq - ( [headDoc, docSeparator, body] - ++ case mWhereDocs of + docAddBaseY BrIndentRegular + $ docSeq + ([headDoc, docSeparator, body] ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] - ) - addAlternative $ + ) + addAlternative + $ -- pattern .. = -- .. -- pattern .. <- -- .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) - ) + docAddBaseY BrIndentRegular + $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> + docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) + ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn @@ -671,18 +681,21 @@ layoutLPatSyn name (InfixCon left right) = do layoutLPatSyn name (RecCon recArgs) = do docName <- lrdrNameToTextAnn name args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq . fmap docLit - $ [docName, Text.pack " { " ] + docSeq + . fmap docLit + $ [docName, Text.pack " { "] <> intersperse (Text.pack ", ") args <> [Text.pack " }"] -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms -layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere + :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG _ (L _ lbinds) _) -> do binderDoc <- docLit $ Text.pack "=" - Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + Just + <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing -------------------------------------------------------------------------------- @@ -692,9 +705,10 @@ layoutPatSynWhere hs = case hs of layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl _ name vars fixity typ -> do - let isInfix = case fixity of - Prefix -> False - Infix -> True + let + isInfix = case fixity of + Prefix -> False + Infix -> True -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl @@ -723,9 +737,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do -- This isn't quite right, but does give syntactically valid results let needsParens = not (null rest) || hasOwnParens docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - ] + $ [docLit $ Text.pack "type", docSeparator] ++ [ docParenL | needsParens ] ++ [ layoutTyVarBndr False a , docSeparator @@ -737,13 +749,13 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do ++ fmap (layoutTyVarBndr True) rest else docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc @@ -752,11 +764,11 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name - docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] + docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] KindedTyVar _ _ name kind -> do nameStr <- lrdrNameToTextAnn name docSeq - $ [ docSeparator | needsSep ] + $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" @@ -784,7 +796,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name + nameStr <- lrdrNameToTextAnn name needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass @@ -795,33 +807,35 @@ layoutTyFamInstDecl inClass outerNode tfid = do makeForallDoc bndrs = do bndrDocs <- layoutTyVarBndrs bndrs docSeq - ( [docLit (Text.pack "forall")] + ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs ) lhs = docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] + . docSeq + $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] - hasComments <- (||) + hasComments <- + (||) <$> hasAnyRegularCommentsConnected outerNode <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc -layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats + :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm + HsValArg tm -> layoutType tm HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change -- is a bit strange. Hopefully this does not ignore any important -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" + HsArgPar _l -> error "brittany internal error: HsArgPar{}" -------------------------------------------------------------------------------- -- ClsInstDecl @@ -836,27 +850,27 @@ layoutClsInst :: ToBriDoc ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) ] where layoutInstanceHead :: ToBriDocM BriDocNumbered layoutInstanceHead = briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren <$> lcid removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] , cid_datafam_insts = [] } @@ -864,7 +878,11 @@ layoutClsInst lcid@(L _ cid) = docLines docSortedLines :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = - allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l + allocateNode + . BDFLines + . fmap unLoc + . List.sortOn (ExactPrint.rs . getLoc) + =<< sequence l layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig @@ -876,8 +894,8 @@ layoutClsInst lcid@(L _ cid) = docLines joinBinds :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n + Left ns -> docLines $ return <$> ns + Right n -> return n layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) @@ -943,10 +961,11 @@ layoutClsInst lcid@(L _ cid) = docLines stripWhitespace' t = Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t where - go [] = [] + go [] = [] go (line1 : lineR) = case Text.stripStart line1 of - st | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR + st + | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "newtype" `Text.isPrefixOf` t') @@ -969,7 +988,12 @@ layoutLhsAndType hasComments lhs sep typeDoc = do -- lhs = type -- lhs :: type addAlternativeCond (not hasComments) $ docSeq - [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] + [ lhs + , docSeparator + , docLitS sep + , docSeparator + , docForceSingleline typeDoc + ] -- lhs -- :: typeA -- -> typeB diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 344454c..3bc4c67 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -4,149 +4,150 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( GenLocated(L), SrcSpan, AnnKeywordId(..), RdrName(..) ) -import GHC.Hs -import GHC.Types.Name +import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) import qualified GHC.Data.FastString as FastString -import GHC.Types.Basic - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type - - +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Types.Name +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils layoutExpr :: ToBriDoc HsExpr layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of HsVar _ vname -> do docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> - docLit $ Text.pack $ occNameString oname + HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '#' : label + let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '?' : label + let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label HsOverLit _ olit -> do allocateNode $ overLitValBriDoc $ ol_val olit HsLit _ lit -> do allocateNode $ litBriDoc lit HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds {} <- llocals - , L _ (GRHS _ [] body) <- lgrhs + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds{} <- llocals + , L _ (GRHS _ [] body) <- lgrhs -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let shouldPrefixSeparator = case p of + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let + shouldPrefixSeparator = case p of L _ LazyPat{} -> isFirst L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let funcPatternPartLine = - docCols ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- + docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let + funcPatternPartLine = docCols + ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing - $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing $ docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> - unknownNodeError "HsLam too complex" lexpr + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> unknownNodeError "HsLam too complex" lexpr HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing $ docAddBaseY BrIndentRegular $ - (docLit $ Text.pack "\\case {}") + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ (docLit $ Text.pack "\\case {}") HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r:list) l - x -> (x, list) + let + gather + :: [LHsExpr GhcPs] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [LHsExpr GhcPs]) + gather list = \case + L _ (HsApp _ l r) -> gather (r : list) l + x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 - let colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq + let + colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs hasComments <- hasAnyCommentsConnected exp2 @@ -158,13 +159,13 @@ layoutExpr lexpr@(L _ expr) = do : spacifyDocs (docForceSingleline <$> paramDocs) -- foo x -- y - addAlternativeCond allowFreeIndent - $ docSeq + addAlternativeCond allowFreeIndent $ docSeq [ appSep (docForceSingleline headDoc) , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ docForceSingleline <$> paramDocs + $ docForceSingleline + <$> paramDocs ] -- foo -- x @@ -173,30 +174,25 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docForceSingleline headDoc) - ( docNonBottomSpacing - $ docLines paramDocs - ) + (docForceSingleline headDoc) + (docNonBottomSpacing $ docLines paramDocs) -- ( multi -- line -- function -- ) -- x -- y - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - headDoc - ( docNonBottomSpacing - $ docLines paramDocs - ) + addAlternative $ docAddBaseY BrIndentRegular $ docPar + headDoc + (docNonBottomSpacing $ docLines paramDocs) HsApp _ exp1 exp2 -> do -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 docAlt [ -- func arg - docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + docSeq + [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] , -- func argline1 -- arglines -- e.g. @@ -209,77 +205,70 @@ layoutExpr lexpr@(L _ expr) = do -- anyways, so it is _always_ par-spaced. $ docAddBaseY BrIndentRegular $ docSeq - [ appSep $ docForceSingleline expDoc1 - , docForceParSpacing expDoc2 - ] + [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] , -- func -- arg - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docForceSingleline expDoc1) (docNonBottomSpacing expDoc2) , -- fu -- nc -- ar -- gument - docAddBaseY BrIndentRegular - $ docPar - expDoc1 - expDoc2 + docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 ] HsAppType _ exp1 (HsWC _ ty1) -> do t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 docAlt [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar - e - (docSeq [docLit $ Text.pack "@", t ]) + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar e (docSeq [docLit $ Text.pack "@", t]) ] OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft + let + gather + :: [(LHsExpr GhcPs, LHsExpr GhcPs)] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) + gather opExprList = \case + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight + appListDocs <- appList `forM` \(x, y) -> + [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight allowSinglelinePar <- do hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp + hasComOp <- hasAnyCommentsConnected expOp pure $ not hasComLeft && not hasComOp - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True runFilteredAlternative $ do -- > one + two + three -- or -- > one + two + case x of -- > _ -> three - addAlternativeCond allowSinglelinePar - $ docSeq + addAlternativeCond allowSinglelinePar $ docSeq [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] + , docSeq $ appListDocs <&> \(od, ed) -> docSeq + [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] , appSep $ docForceSingleline opLastDoc , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc + expLastDoc ] -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) @@ -294,29 +283,31 @@ layoutExpr lexpr@(L _ expr) = do -- > one -- > + two -- > + three - addAlternative $ - docPar - leftOperandDoc - ( docLines - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + addAlternative $ docPar + leftOperandDoc + (docLines + $ (appListDocs <&> \(od, ed) -> + docCols ColOpPrefix [appSep od, docSetBaseY ed] ) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let + leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line - addAlternative - $ docSeq + addAlternative $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceSingleline expDocRight @@ -331,35 +322,35 @@ layoutExpr lexpr@(L _ expr) = do -- two-line addAlternative $ do let - expDocOpAndRight = docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + expDocOpAndRight = docForceSingleline $ docCols + ColOpPrefix + [appSep $ expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight -- TODO: in both cases, we don't force expDocLeft to be -- single-line, which has certain.. interesting consequences. -- At least, the "two-line" label is not entirely -- accurate. -- one-line + par - addAlternativeCond allowPar - $ docSeq + addAlternativeCond allowPar $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceParSpacing expDocRight ] -- more lines addAlternative $ do - let expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + let + expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight + $ docPar expDocLeft expDocOpAndRight NegApp _ op _ -> do opDoc <- docSharedWrapper layoutExpr op - docSeq [ docLit $ Text.pack "-" - , opDoc - ] + docSeq [docLit $ Text.pack "-", opDoc] HsPar _ innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -369,7 +360,8 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack ")" ] , docSetBaseY $ docLines - [ docCols ColOpPrefix + [ docCols + ColOpPrefix [ docLit $ Text.pack "(" , docAddBaseY (BrIndentSpecial 2) innerExpDoc ] @@ -378,33 +370,33 @@ layoutExpr lexpr@(L _ expr) = do ] SectionL _ left op -> do -- TODO: add to testsuite leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple _ args boxity -> do - let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e); - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs - $ docSharedWrapper - $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM + let + argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e) + (L _ (Missing NoExtField)) -> (arg, Nothing) + argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> + docWrapNode arg $ maybe docEmpty layoutExpr exprM hasComments <- orM - ( hasCommentsBetween lexpr AnnOpenP AnnCloseP + (hasCommentsBetween lexpr AnnOpenP AnnCloseP : map hasAnyCommentsBelow args ) - let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) + let + (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) case splitFirstLast argDocs of - FirstLastEmpty -> docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) closeLit - ] + FirstLastEmpty -> + docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] FirstLastSingleton e -> docAlt - [ docCols ColTuple + [ docCols + ColTuple [ openLit , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e , closeLit @@ -419,74 +411,88 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] - addAlternative $ - let - start = docCols ColTuples - [appSep openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + ++ [ docSeq + [ docCommaSep + , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) + , closeLit + ] + ] + addAlternative + $ let + start = docCols ColTuples [appSep openLit, e1] + linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] + lineN = docCols + ColTuples + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase _ cExp (MG _ (L _ []) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp docAlt - [ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] + [ docAddBaseY BrIndentRegular $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") ] HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches docAlt - [ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq + [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq [ appSep $ docLit $ Text.pack "case" , appSep $ docForceSingleline cExpDoc , docLit $ Text.pack "of" - ]) - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + ] + ) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "of") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "of") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs ) + ) ] HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr + ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr hasComments <- hasAnyCommentsBelow lexpr - let maySpecialIndent = - case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 + let + maySpecialIndent = case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. docSetIndentLevel $ runFilteredAlternative $ do -- if _ then _ else _ - addAlternativeCond (not hasComments) - $ docSeq + addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc , appSep $ docLit $ Text.pack "then" @@ -511,25 +517,34 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - ( docSeq + (docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) + , docNodeAnnKW lexpr (Just AnnIf) + $ docForceSingleline ifExprDoc + ] + ) (docLines [ docAddBaseY BrIndentRegular $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + $ docNonBottomSpacing + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc + $ docPar (docLit $ Text.pack "else") elseExprDoc ] - , docAddBaseY BrIndentRegular - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) + ] + ) -- either -- if multi -- line @@ -547,62 +562,69 @@ layoutExpr lexpr@(L _ expr) = do -- else -- stuff -- note that this does _not_ have par-spacing - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc ] , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - addAlternative - $ docSetBaseY - $ docLines - [ docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc ] + ) + addAlternative $ docSetBaseY $ docLines + [ docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" hasComments <- hasAnyCommentsBelow lexpr docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") - (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) + (layoutPatternBindFinal + Nothing + binderDoc + Nothing + clauseDocs + Nothing + hasComments + ) HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = - case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x + ifIndentFreeElse x y = case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), -- but is here due to ghc-exactprint's DP handling of "let" in @@ -615,36 +637,35 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) - $ appSep $ docForceSingleline bindDoc + , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline + bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ] addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) + [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc ] + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) + ] , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY expDoc1) + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse + docSetBaseAndIndent + docForceSingleline + expDoc1 ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) + ] ] - Just bindDocs@(_:_) -> runFilteredAlternative $ do + Just bindDocs@(_ : _) -> runFilteredAlternative $ do --either -- let -- a = b @@ -658,102 +679,91 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - let noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular - $ docForceParSpacing expDoc1 - ] + let + noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 ] + ] addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docSeq + IndentPolicyFree -> docLines + [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines bindDocs ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY expDoc1 - ] + , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] ] - addAlternative - $ docLines + addAlternative $ docLines [ docNodeAnnKW lexpr (Just AnnLet) $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of DoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) MDoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ docForceSingleline <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative $ - let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x + | case x of + ListComp -> True + MonadComp -> True + _ -> False + -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq + $ List.intersperse docCommaSep + $ docForceSingleline + <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative + $ let + start = docCols + ColListComp + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack + "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1 : sM) = List.init stmtDocs + line1 = + docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] _ -> do -- TODO unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr + ExplicitList _ _ elems@(_ : _) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of FirstLastEmpty -> docSeq @@ -777,109 +787,106 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse + docCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) + ) ++ [docLit $ Text.pack "]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> - docLit $ Text.pack "[]" - RecordCon _ lname fields -> - case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- fs - `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> docCols ColList [docCommaSep, d] + lineN = docCols + ColList + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ExplicitList _ _ [] -> docLit $ Text.pack "[]" + RecordCon _ lname fields -> case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- + fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression False indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just (L _ 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- + fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr + recordExpression True indentPolicy lexpr nameDoc fieldDocs + _ -> unknownNodeError "RecordCon with puns" lexpr RecordUpd _ rExpr fields -> do rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- fields - `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFs <- + fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do rFExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ case ambName of Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) recordExpression False indentPolicy lexpr rExprDoc rFs ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 - docSeq - [ appSep expDoc - , appSep $ docLit $ Text.pack "::" - , typDoc - ] - ArithSeq _ Nothing info -> - case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> - briDocByExactInlineOnly "ArithSeq" lexpr + docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] + ArithSeq _ Nothing info -> case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr HsBracket{} -> do -- TODO briDocByExactInlineOnly "HsBracket{}" lexpr @@ -892,11 +899,12 @@ layoutExpr lexpr@(L _ expr) = do HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do allocateNode $ BDFPlain (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]") + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]" + ) HsSpliceE{} -> do -- TODO briDocByExactInlineOnly "HsSpliceE{}" lexpr @@ -928,78 +936,79 @@ recordExpression -> IndentPolicy -> GenLocated SrcSpan lExpr -> ToBriDocM BriDocNumbered - -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] + -> [ ( GenLocated SrcSpan name + , Text + , Maybe (ToBriDocM BriDocNumbered) + ) + ] -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = - docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = - docSeq -- this case might still be incomplete, and is probably not used +recordExpression False _ lexpr nameDoc [] = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do let (rF1f, rF1n, rF1e) = rF1 runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } - addAlternative - $ docSeq + addAlternative $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr + , docSeq $ List.intersperse docCommaSep $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr , if dotdot - then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator + then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator , docLit $ Text.pack "}" ] -- hanging single-line fields -- container { fieldA = blub -- , fieldB = blub -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docSeq + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRec + , docSetBaseY + $ docLines + $ let + line1 = docCols + ColRec [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit rF1n , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty + Just x -> docWrapNodeRest rF1f $ docSeq + [appSep $ docLit $ Text.pack "=", docForceSingleline x] + Nothing -> docEmpty ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docSeq + [appSep $ docLit $ Text.pack "=", docForceSingleline x] Nothing -> docEmpty - ] + ] dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] + in [line1] ++ lineR ++ [dotdotLine, lineN] ] -- non-hanging with expressions placed to the right of the names -- container @@ -1007,77 +1016,75 @@ recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do -- , fieldB = potentially -- multiline -- } - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield - $ docCols ColRec + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing + $ docLines + $ let + line1 = docCols + ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec [ docCommaSep , appSep $ docLit fText , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq [ appSep $ docLit $ Text.pack "=" - , docForceParSpacing x - ] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty ] - dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) + dotdotLine = if dotdot + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ) litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t _ -> error "litBriDoc: literal with no SourceText" overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 8fb094b..27256ef 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -2,20 +2,11 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where - - -import Language.Haskell.Brittany.Internal.Prelude - -import Language.Haskell.Brittany.Internal.Types - -import GHC.Hs - - +import GHC.Hs +import Language.Haskell.Brittany.Internal.Types layoutExpr :: ToBriDoc HsExpr --- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) - litBriDoc :: HsLit GhcPs -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 39b7a49..dc1fafe 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -4,26 +4,22 @@ module Language.Haskell.Brittany.Internal.Layouters.IE where -import Language.Haskell.Brittany.Internal.Prelude import qualified Data.List.Extra import qualified Data.Text as Text +import GHC + ( AnnKeywordId(..) + , GenLocated(L) + , Located + , ModuleName + , moduleNameString + , unLoc + ) +import GHC.Hs import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import GHC ( unLoc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - , Located - , ModuleName - ) -import GHC.Hs - -import Language.Haskell.Brittany.Internal.Utils - - +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils prepareName :: LIEWrappedName name -> Located name prepareName = ieLWrappedName @@ -37,36 +33,41 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] IEThingWith _ x _ ns _ -> do hasComments <- orM - ( hasCommentsBetween lie AnnOpenP AnnCloseP + (hasCommentsBetween lie AnnOpenP AnnCloseP : hasAnyCommentsBelow x : map hasAnyCommentsBelow ns ) let sortedNs = List.sortOn wrappedNameToText ns runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] + $ docSeq + $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc sortedNs) ++ [docParenR] addAlternative $ docWrapNodeRest lie $ docAddBaseY BrIndentRegular - $ docPar - (layoutWrapped lie x) - (layoutItems (splitFirstLast sortedNs)) + $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) where nameDoc = docLit <=< lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] + , docParenR + ] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] + , docParenR + ] layoutItems (FirstLast n1 nMs nN) = docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs - ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] + ++ [ docSeq + [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] + , docParenR + ] IEModuleContents _ n -> docSeq [ docLit $ Text.pack "module" , docSeparator @@ -75,7 +76,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEPattern n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "pattern " <> name @@ -92,33 +93,36 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] + :: SortItemsFlag + -> Located [LIE GhcPs] + -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] - let sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText - $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies + let + sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let + ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] + FirstLastEmpty -> [] FirstLastSingleton ie -> [ie] FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] pure $ fmap pure ieCommaDocs -- returned shared nodes where mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] + mergeGroup [] = [] mergeGroup items@[_] = items - mergeGroup items = if + mergeGroup items = if | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items -- proper means that if it is a ThingWith, it does not contain a wildcard -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). @@ -131,21 +135,22 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True - _ -> False + _ -> False thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{} ) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 ( L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder l1@(L _ IEVar{}) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 (L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l - (IEThingWith x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) + (IEThingWith + x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) ) thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -164,9 +169,10 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs + :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies + ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies runFilteredAlternative $ case ieDs of [] -> do @@ -176,14 +182,14 @@ layoutLLIEs enableSingleline shouldSort llies = do docParenR (ieDsH : ieDsT) -> do addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] + $ docSeq + $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) ++ [docParenR] addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT ++ [docParenR] -- | Returns a "fingerprint string", not a full text representation, nor even @@ -191,26 +197,27 @@ layoutLLIEs enableSingleline shouldSort llies = do -- Used for sorting, not for printing the formatter's output source code. wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n + L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. lieToText :: LIE GhcPs -> Text lieToText = \case - L _ (IEVar _ wn ) -> wrappedNameToText wn - L _ (IEThingAbs _ wn ) -> wrappedNameToText wn - L _ (IEThingAll _ wn ) -> wrappedNameToText wn + L _ (IEVar _ wn) -> wrappedNameToText wn + L _ (IEThingAbs _ wn) -> wrappedNameToText wn + L _ (IEThingAll _ wn) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn -- TODO: These _may_ appear in exports! -- Need to check, and either put them at the top (for module) or do some -- other clever thing. L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" where moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) + moduleNameToText (L _ name) = + Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 1b19145..df9d00f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -2,26 +2,18 @@ module Language.Haskell.Brittany.Internal.Layouters.Import where -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( unLoc - , GenLocated(L) - , moduleNameString - , Located - ) -import GHC.Hs -import GHC.Types.Basic +import GHC (GenLocated(L), Located, moduleNameString, unLoc) +import GHC.Hs +import GHC.Types.Basic import GHC.Unit.Types (IsBootInterface(..)) - - +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types prepPkg :: SourceText -> String prepPkg rawN = case rawN of @@ -36,111 +28,132 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered layoutImport importD = case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + importAsCol <- + mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack + indentPolicy <- + mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let - compact = indentPolicy /= IndentPolicyFree + compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = - let qualifiedPart = if q /= NotQualified then length "qualified " else 0 - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal + let + qualifiedPart = if q /= NotQualified then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = case src of + IsBoot -> length "{-# SOURCE #-} " + NotBoot -> 0 + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength + asCost = length "as " + hidingParenCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" - , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } + , case src of + IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}" + NotBoot -> docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty - , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty + , if q /= NotQualified + then appSep $ docLit $ Text.pack "qualified" + else docEmpty , maybe docEmpty (appSep . docLit) pkgNameT ] indentName = if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = - indentName $ appSep $ docLit modNameT - hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 + modNameD = indentName $ appSep $ docLit modNameT + hidDocCol = + if hiding then importCol - hidingParenCost else importCol - 2 hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = if hiding - then appSep $ docLit $ Text.pack "hiding" - else docEmpty + hidDoc = + if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of + bindingsD = case mllies of Nothing -> docEmpty Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docAlt - [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] - , let makeParIfHiding = if hiding + then docAlt + [ docSeq + [ hidDoc + , docForceSingleline $ layoutLLIEs True ShouldSortItems llies + ] + , let + makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar - (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - ( docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + ] + else do + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq + [hidDoc, docParenLSep, docWrapNode llies docEmpty] + ) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + else docSeq + [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD] + ) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + -- ..[hiding].( b + -- , b' + -- ) + (ieD : ieDs') -> docPar + (docSeq + [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] + ) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular $ - docPar (docSeq [importHead, asDoc]) bindingsD - ] - else - case masT of + then + let asDoc = maybe docEmpty makeAsDoc masT + in + docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular + $ docPar (docSeq [importHead, asDoc]) bindingsD + ] + else case masT of Just n -> if enoughRoom - then docLines - [ docSeq [importHead, asDoc], bindingsD] + then docLines [docSeq [importHead, asDoc], bindingsD] else docLines [importHead, asDoc, bindingsD] where enoughRoom = nameCost < importAsCol - asCost - asDoc = - docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n + asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) + $ makeAsDoc n Nothing -> if enoughRoom then docSeq [importHead, bindingsD] else docLines [importHead, bindingsD] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 52c2cd1..efae541 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -3,34 +3,27 @@ module Language.Haskell.Brittany.Internal.Layouters.Module where -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) +import GHC.Hs import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..)) -import GHC.Hs -import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types - ( DeltaPos(..) - , deltaRow - , commentContents - ) - - +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types + (DeltaPos(..), commentContents, deltaRow) layoutModule :: ToBriDoc' HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do + HsModule _ Nothing _ imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) @@ -41,43 +34,38 @@ layoutModule lmod@(L _ mod') = case mod' of -- groupify commentedImports `forM_` tellDebugMessShow -- sortedImports <- sortImports imports let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- mAsk - <&> _conf_layout - .> _lconfig_allowSingleLineExportList - .> confUnpack + allowSingleLineExportList <- + mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack -- the config should not prevent single-line layout when there is no -- export list - let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les + let + allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les docLines $ docSeq [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ - docForceSingleline - $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative - $ docLines + addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + addAlternative $ docLines [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docSeq [ - docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) + (docSeq + [ docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + ) ] ] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] @@ -89,7 +77,7 @@ data CommentedImport instance Show CommentedImport where show = \case - EmptyLine -> "EmptyLine" + EmptyLine -> "EmptyLine" IndependentComment _ -> "IndependentComment" ImportStatement r -> "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show @@ -102,8 +90,9 @@ data ImportStatementRecord = ImportStatementRecord } instance Show ImportStatementRecord where - show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) + show r = + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) transformToCommentedImport :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] @@ -121,10 +110,11 @@ transformToCommentedImport is = do accumF accConnectedComm (annMay, decl) = case annMay of Nothing -> ( [] - , [ ImportStatement ImportStatementRecord { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } + , [ ImportStatement ImportStatementRecord + { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } ] ) Just ann -> @@ -136,7 +126,7 @@ transformToCommentedImport is = do :: [(Comment, DeltaPos)] -> [(Comment, DeltaPos)] -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) + go acc [] = ([], acc, 0) go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs go acc ((c1, DP (y, x)) : xs) = @@ -153,8 +143,8 @@ transformToCommentedImport is = do , convertedIndependentComments ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm , importStatement = decl } ] @@ -168,14 +158,14 @@ sortCommentedImports = where unpackImports :: [CommentedImport] -> [CommentedImport] unpackImports xs = xs >>= \case - l@EmptyLine -> [l] + l@EmptyLine -> [l] l@IndependentComment{} -> [l] ImportStatement r -> map IndependentComment (commentsBefore r) ++ [ImportStatement r] mergeGroups :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] mergeGroups xs = xs >>= \case - Left x -> [x] + Left x -> [x] Right y -> ImportStatement <$> y sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups = @@ -185,25 +175,23 @@ sortCommentedImports = groupify cs = go [] cs where go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest + (l@EmptyLine : rest) -> Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] + (ImportStatement r : rest) -> go [r] rest + [] -> [] go acc = \case (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : Right (reverse acc) : go [] rest (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] + [] -> [Right (reverse acc)] commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered commentedImportsToDoc = \case EmptyLine -> docLitS "" IndependentComment c -> commentToDoc c - ImportStatement r -> - docSeq - ( layoutImport (importStatement r) - : map commentToDoc (commentsAfter r) - ) + ImportStatement r -> docSeq + (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) where - commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) + commentToDoc (c, DP (_y, x)) = + docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 4b99bca..88a10e4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -3,28 +3,19 @@ module Language.Haskell.Brittany.Internal.Layouters.Pattern where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import qualified Data.Text as Text +import GHC (GenLocated(L), ol_val) +import GHC.Hs import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import GHC ( GenLocated(L) - , ol_val - ) -import GHC.Hs -import GHC.Types.Basic - +import GHC.Types.Basic +import Language.Haskell.Brittany.Internal.LayouterBasics import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type - - +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types -- | layouts patterns (inside function bindings, case alternatives, let -- bindings or do notation). E.g. for input @@ -38,17 +29,15 @@ import Language.Haskell.Brittany.Internal.Layouters.Type -- the different cases below. layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr - VarPat _ n -> - fmap Seq.singleton $ docLit $ lrdrNameToText n + VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat _ lit -> - fmap Seq.singleton $ allocateNode $ litBriDoc lit + LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr ParPat _ inner -> do -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" + left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" innerDocs <- colsWrapPat =<< layoutPat inner return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right @@ -74,10 +63,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return <$> docLit nameDoc else do x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList - $ sequence - $ spacifyDocs - $ fmap colsWrapPat argDocs + xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap + colsWrapPat + argDocs return $ x1 Seq.<| xR ConPat _ lname (InfixCon left right) -> do -- a :< b -> expr @@ -90,7 +78,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname @@ -103,37 +91,34 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName + , docSeq $ List.intersperse docCommaSep $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName , docSeparator , docLit $ Text.pack "}" ] ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname - Seq.singleton <$> docSeq - [ appSep $ docLit t - , docLit $ Text.pack "{..}" - ] - ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do + Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"] + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) + | dotdoti == length fs -> do -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case (fieldName, Just fieldDoc) -> [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" @@ -141,13 +126,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docCommaSep ] (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] + , docLit $ Text.pack "..}" + ] TuplePat _ args boxity -> do -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR + Boxed -> wrapPatListy args "()" docParenL docParenR Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep AsPat _ asName asPat -> do -- bind@nestedpat -> expr @@ -184,10 +169,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of wrapPatPrepend pat1 (docLit $ Text.pack "~") NPat _ llit@(L _ ol) mNegative _ -> do -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val + ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] + Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat @@ -196,9 +182,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend - :: LPat GhcPs - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) + :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of @@ -220,8 +204,5 @@ wrapPatListy elems both start end = do x1 Seq.:< rest -> do sDoc <- start eDoc <- end - rest' <- rest `forM` \bd -> docSeq - [ docCommaSep - , return bd - ] + rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd] return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 95f7273..528853a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -4,26 +4,19 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text +import GHC (GenLocated(L)) +import GHC.Hs +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( GenLocated(L) - ) -import GHC.Hs - -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Decl import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr - - +import Language.Haskell.Brittany.Internal.Layouters.Pattern layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt lstmt@(L _ stmt) = do @@ -53,12 +46,12 @@ layoutStmt lstmt@(L _ stmt) = do ] ] LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree + let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" + Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [bindDoc] -> docAlt [ -- let bind = expr docCols @@ -68,9 +61,10 @@ layoutStmt lstmt@(L _ stmt) = do f = case indentPolicy of IndentPolicyFree -> docSetBaseAndIndent IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc + IndentPolicyMultiple + | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc ] , -- let -- bind = expr @@ -84,10 +78,11 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (isFree || indentFourPlus) $ docSeq [ appSep $ docLit $ Text.pack "let" - , let f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs + , let + f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs ] -- let -- aaa = expra @@ -95,8 +90,9 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (not indentFourPlus) $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 02b388c..fbba444 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -2,14 +2,7 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where - - -import Language.Haskell.Brittany.Internal.Prelude - -import Language.Haskell.Brittany.Internal.Types - -import GHC.Hs - - +import GHC.Hs +import Language.Haskell.Brittany.Internal.Types layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index ed0dd26..7ccb461 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -3,28 +3,18 @@ module Language.Haskell.Brittany.Internal.Layouters.Type where - - +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Utils.Outputable (ftext, showSDocUnsafe) +import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Utils - ( splitFirstLast - , FirstLastView(..) - ) - -import GHC ( GenLocated(L) - , AnnKeywordId (..) - ) -import GHC.Hs -import GHC.Utils.Outputable ( ftext, showSDocUnsafe ) -import GHC.Types.Basic - - +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + (FirstLastView(..), splitFirstLast) layoutType :: ToBriDoc HsType layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of @@ -32,76 +22,66 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsTyVar _ promoted name -> do t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of - IsPromoted -> docSeq - [ docSeparator - , docTick - , docWrapNode name $ docLit t - ] + IsPromoted -> + docSeq [docSeparator, docTick, docWrapNode name $ docLit t] NotPromoted -> docWrapNode name $ docLit t HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do let bndrs = getBinders hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs forallDoc = docAlt - [ let - open = docLit $ Text.pack "forall" - in docSeq ([open]++tyVarDocLineList) + [ let open = docLit $ Text.pack "forall" + in docSeq ([open] ++ tyVarDocLineList) , docPar - (docLit (Text.pack "forall")) - (docLines - $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ]) + (docLit (Text.pack "forall")) + (docLines $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" + ] + ) ] contextDoc = case cntxtDocs of [] -> docLit $ Text.pack "()" [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] + open = docCols + ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs + ] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) cntxtDoc - ] + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] in docPar open $ docLines $ list ++ [close] ] docAlt -- :: forall a b c . (Foo a b c) => a b -> c [ docSeq [ if null bndrs - then docEmpty - else let + then docEmpty + else + let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) + in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) , docForceSingleline contextDoc , docLit $ Text.pack " => " , docForceSingleline typeDoc @@ -111,75 +91,74 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - forallDoc - ( docLines - [ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) - $ contextDoc - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] + forallDoc + (docLines + [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) $ contextDoc ] - ) + , docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] + ] + ) ] HsForAllTy _ hsf typ2 -> do let bndrs = getBinders hsf typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs docAlt -- forall x . x [ docSeq [ if null bndrs - then docEmpty - else let + then docEmpty + else + let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open]++tyVarDocLineList++[close]) + in docSeq ([open] ++ tyVarDocLineList ++ [close]) , docForceSingleline $ return $ typeDoc ] -- :: forall x -- . x , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ) -- :: forall -- (x :: *) -- . x , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ] - ) - ++[ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> + docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" ] - ] ) + ++ [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ] + ) ] HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do typeDoc <- docSharedWrapper layoutType typ1 @@ -190,29 +169,27 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) - $ head cntxtDocs - ] + open = docCols + ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs + ] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) - $ cntxtDoc - ] + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] in docPar open $ docLines $ list ++ [close] ] - let maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id docAlt -- (Foo a b c) => a b -> c [ docSeq @@ -224,37 +201,39 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - (docForceSingleline contextDoc) - ( docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) + (docForceSingleline contextDoc) + (docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) ] HsFunTy _ _ typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id hasComments <- hasAnyCommentsBelow ltype - docAlt $ - [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 + docAlt + $ [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 + ] + | not hasComments ] - | not hasComments - ] ++ - [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) - $ maybeForceML typeDoc2 - ] - ) - ] + ++ [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 + ] + ) + ] HsParTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -264,24 +243,28 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack ")" ] , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack ")") + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack ")") ] HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 - final -> (final, list) + let + gather + :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 + final -> (final, list) let (typHead, typRest) = gather [typ2] typ1 docHead <- docSharedWrapper layoutType typHead docRest <- docSharedWrapper layoutType `mapM` typRest docAlt [ docSeq - $ docForceSingleline docHead : (docRest >>= \d -> - [ docSeparator, docForceSingleline d ]) + $ docForceSingleline docHead + : (docRest >>= \d -> [docSeparator, docForceSingleline d]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] HsAppTy _ typ1 typ2 -> do @@ -293,9 +276,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docSeparator , docForceSingleline typeDoc2 ] - , docPar - typeDoc1 - (docEnsureIndent BrIndentRegular typeDoc2) + , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) ] HsListTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 @@ -306,51 +287,61 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack "]" ] , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack "]") + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack "]") ] HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where - unboxed = if null typs then error "brittany internal error: unboxed unit" - else unboxedL + unboxed = if null typs + then error "brittany internal error: unboxed unit" + else unboxedL simple = if null typs then unitL else simpleL unitL = docLit $ Text.pack "()" simpleL = do docs <- docSharedWrapper layoutType `mapM` typs - let end = docLit $ Text.pack ")" - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) + let + end = docLit $ Text.pack ")" + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt - [ docSeq $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] + [ docSeq + $ [docLit $ Text.pack "("] + ++ docWrapNodeRest ltype commaDocs + ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) + in + docPar + (docAddBaseY (BrIndentSpecial 2) $ line1) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs - let start = docParenHashLSep - end = docParenHashRSep + let + start = docParenHashLSep + end = docParenHashRSep docAlt - [ docSeq $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] + [ docSeq + $ [start] + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) + ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ lines ++ [end]) @@ -419,20 +410,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq - [ docWrapNodeRest ltype - $ docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + [ docWrapNodeRest ltype $ docLit $ Text.pack + ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") , docForceSingleline typeDoc1 ] , docPar - ( docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) - ) - (docCols ColTyOpPrefix - [ docWrapNodeRest ltype - $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ]) + (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ] + ) ] -- TODO: test KindSig HsKindSig _ typ1 kind1 -> do @@ -473,7 +462,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] else docPar typeDoc1 - ( docCols + (docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) kindDoc1 @@ -544,7 +533,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq - $ [docLit $ Text.pack "'["] + $ [docLit $ Text.pack "'["] ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"] , case splitFirstLast typDocs of @@ -569,19 +558,23 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse + specialCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) + ) ++ [docLit $ Text.pack " ]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> - docCols ColList [specialCommaSep, d] - lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] + lineN = docCols + ColList + [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype @@ -592,8 +585,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy NoSourceText _ -> error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> - docLit $ Text.pack "_" + HsWildCardTy _ -> docLit $ Text.pack "_" HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype HsStarTy _ isUnicode -> do @@ -606,14 +598,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of k <- docSharedWrapper layoutType kind docAlt [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar - t - (docSeq [docLit $ Text.pack "@", k ]) + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar t (docSeq [docLit $ Text.pack "@", k]) ] layoutTyVarBndrs diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs index 29dc13c..b4785a5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -2,28 +2,24 @@ module Language.Haskell.Brittany.Internal.Obfuscation where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Data.Char import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified GHC.OldList as List - -import Data.Char -import System.Random - - +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import System.Random obfuscate :: Text -> IO Text obfuscate input = do let predi x = isAlphaNum x || x `elem` "_'" let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x + let + exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x let filtered = filter exceptionFilter idents mappings <- fmap Map.fromList $ filtered `forM` \x -> do r <- createAlias x @@ -75,14 +71,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] createAlias :: String -> IO String createAlias xs = go NoHint xs where - go _hint "" = pure "" - go hint (c : cr) = do + go _hint "" = pure "" + go hint (c : cr) = do c' <- case hint of VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr pure (c' : cr') diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs index 87a0c0a..0790989 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,346 +1,195 @@ -module Language.Haskell.Brittany.Internal.Prelude ( module E ) where +module Language.Haskell.Brittany.Internal.Prelude + ( module E + ) where +import GHC.Hs.Extension as E (GhcPs) +import GHC.Types.Name.Reader as E (RdrName) - --- rather project-specific stuff: ---------------------------------- -import GHC.Hs.Extension as E ( GhcPs ) - -import GHC.Types.Name.Reader as E ( RdrName ) - - --- more general: ----------------- - -import Data.Functor.Identity as E ( Identity(..) ) -import Control.Concurrent.Chan as E ( Chan ) -import Control.Concurrent.MVar as E ( MVar - , newEmptyMVar - , newMVar - , putMVar - , readMVar - , takeMVar - , swapMVar - ) -import Data.Int as E ( Int ) -import Data.Word as E ( Word - , Word32 - ) -import Prelude as E ( Integer - , Float - , Double - , undefined - , Eq (..) - , Ord (..) - , Enum (..) - , Bounded (..) - , (<$>) - , (.) - , ($) - , ($!) - , Num (..) - , Integral (..) - , Fractional (..) - , Floating (..) - , RealFrac (..) - , RealFloat (..) - , fromIntegral - , error - , foldr - , foldl - , foldr1 - , id - , map - , subtract - , putStrLn - , putStr - , Show (..) - , print - , fst - , snd - , (++) - , not - , (&&) - , (||) - , curry - , uncurry - , flip - , const - , seq - , reverse - , otherwise - , traverse - , realToFrac - , or - , and - , head - , any - , (^) - , Foldable - , Traversable - ) -import Control.Monad.ST as E ( ST ) -import Data.Bool as E ( Bool(..) ) -import Data.Char as E ( Char - , ord - , chr - ) -import Data.Either as E ( Either(..) - , either - ) -import Data.IORef as E ( IORef ) -import Data.Maybe as E ( Maybe(..) - , fromMaybe - , maybe - , listToMaybe - , maybeToList - , catMaybes - ) -import Data.Monoid as E ( Endo(..) - , All(..) - , Any(..) - , Sum(..) - , Product(..) - , Alt(..) - , mconcat - , Monoid (..) - ) -import Data.Ord as E ( Ordering(..) - , Down(..) - , comparing - ) -import Data.Ratio as E ( Ratio - , Rational - , (%) - , numerator - , denominator - ) -import Data.String as E ( String ) -import Data.Void as E ( Void ) -import System.IO as E ( IO - , hFlush - , stdout - ) -import Data.Proxy as E ( Proxy(..) ) -import Data.Sequence as E ( Seq ) - -import Data.Map as E ( Map ) -import Data.Set as E ( Set ) - -import Data.Text as E ( Text ) - -import Data.Function as E ( fix - , (&) - ) - -import Data.Foldable as E ( foldl' - , foldr' - , fold - , asum - ) - -import Data.List as E ( partition - , null - , elem - , notElem - , minimum - , maximum - , length - , all - , take - , drop - , find - , sum - , zip - , zip3 - , zipWith - , repeat - , replicate - , iterate - , nub - , filter - , intersperse - , intercalate - , isSuffixOf - , isPrefixOf - , dropWhile - , takeWhile - , unzip - , break - , transpose - , sortBy - , mapAccumL - , mapAccumR - , uncons - ) - -import Data.List.NonEmpty as E ( NonEmpty(..) - , nonEmpty - ) - -import Data.Tuple as E ( swap - ) - -import Text.Read as E ( readMaybe - ) - -import Control.Monad as E ( Functor (..) - , Monad (..) - , MonadPlus (..) - , mapM - , mapM_ - , forM - , forM_ - , sequence - , sequence_ - , (=<<) - , (>=>) - , (<=<) - , forever - , void - , join - , replicateM - , replicateM_ - , guard - , when - , unless - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , filterM - , (<$!>) - ) - -import Control.Applicative as E ( Applicative (..) - , Alternative (..) - ) - -import Foreign.Storable as E ( Storable ) -import GHC.Exts as E ( Constraint ) - -import Control.Concurrent as E ( threadDelay - , forkIO - , forkOS - ) - -import Control.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.Bifunctor as E ( bimap ) -import Data.Functor as E ( ($>) ) -import Data.Semigroup as E ( (<>) - , Semigroup(..) - ) - -import Data.Typeable as E ( Typeable - ) - -import Control.Arrow as E ( first - , second - , (***) - , (&&&) - , (>>>) - , (<<<) - ) - -import Data.Version as E ( showVersion - ) - -import Data.List.Extra as E ( nubOrd - , stripSuffix - ) -import Control.Monad.Extra as E ( whenM - , unlessM - , ifM - , notM - , orM - , andM - , anyM - , allM - ) - -import Data.Tree as E ( Tree(..) - ) - -import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) - -- , MultiRWSTNull - -- , MultiRWS - -- , - MonadMultiReader(..) - , MonadMultiWriter(..) - , MonadMultiState(..) - , mGet - -- , runMultiRWST - -- , runMultiRWSTASW - -- , runMultiRWSTW - -- , runMultiRWSTAW - -- , runMultiRWSTSW - -- , runMultiRWSTNil - -- , runMultiRWSTNil_ - -- , withMultiReader - -- , withMultiReader_ - -- , withMultiReaders - -- , withMultiReaders_ - -- , withMultiWriter - -- , withMultiWriterAW - -- , withMultiWriterWA - -- , withMultiWriterW - -- , withMultiWriters - -- , withMultiWritersAW - -- , withMultiWritersWA - -- , withMultiWritersW - -- , withMultiState - -- , withMultiStateAS - -- , withMultiStateSA - -- , withMultiStateA - -- , withMultiStateS - -- , withMultiState_ - -- , withMultiStates - -- , withMultiStatesAS - -- , withMultiStatesSA - -- , withMultiStatesA - -- , withMultiStatesS - -- , withMultiStates_ - -- , inflateReader - -- , inflateMultiReader - -- , inflateWriter - -- , inflateMultiWriter - -- , inflateState - -- , inflateMultiState - -- , mapMultiRWST - -- , mGetRawR - -- , mGetRawW - -- , mGetRawS - -- , mPutRawR - -- , mPutRawW - -- , mPutRawS - ) - -import Control.Monad.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 - ) +import Control.Applicative as E (Alternative(..), Applicative(..)) +import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) +import Control.Concurrent as E (forkIO, forkOS, threadDelay) +import Control.Concurrent.Chan as E (Chan) +import Control.Concurrent.MVar as E + (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) +import Control.Exception as E (assert, bracket, evaluate) +import Control.Monad as E + ( (<$!>) + , (<=<) + , (=<<) + , (>=>) + , Functor(..) + , Monad(..) + , MonadPlus(..) + , filterM + , forM + , forM_ + , forever + , guard + , join + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , mapM + , mapM_ + , replicateM + , replicateM_ + , sequence + , sequence_ + , unless + , void + , when + ) +import Control.Monad.Extra as E + (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) +import Control.Monad.IO.Class as E (MonadIO(..)) +import Control.Monad.ST as E (ST) +import Control.Monad.Trans.Class as E (lift) +import Control.Monad.Trans.Maybe as E (MaybeT(..)) +import Control.Monad.Trans.MultiRWS as E + (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) +import Data.Bifunctor as E (bimap) +import Data.Bool as E (Bool(..)) +import Data.Char as E (Char, chr, ord) +import Data.Data as E (toConstr) +import Data.Either as E (Either(..), either) +import Data.Foldable as E (asum, fold, foldl', foldr') +import Data.Function as E ((&), fix) +import Data.Functor as E (($>)) +import Data.Functor.Identity as E (Identity(..)) +import Data.IORef as E (IORef) +import Data.Int as E (Int) +import Data.List as E + ( all + , break + , drop + , dropWhile + , elem + , filter + , find + , intercalate + , intersperse + , isPrefixOf + , isSuffixOf + , iterate + , length + , mapAccumL + , mapAccumR + , maximum + , minimum + , notElem + , nub + , null + , partition + , repeat + , replicate + , sortBy + , sum + , take + , takeWhile + , transpose + , uncons + , unzip + , zip + , zip3 + , zipWith + ) +import Data.List.Extra as E (nubOrd, stripSuffix) +import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) +import Data.Map as E (Map) +import Data.Maybe as E + (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) +import Data.Monoid as E + ( All(..) + , Alt(..) + , Any(..) + , Endo(..) + , Monoid(..) + , Product(..) + , Sum(..) + , mconcat + ) +import Data.Ord as E (Down(..), Ordering(..), comparing) +import Data.Proxy as E (Proxy(..)) +import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) +import Data.Semigroup as E ((<>), Semigroup(..)) +import Data.Sequence as E (Seq) +import Data.Set as E (Set) +import Data.String as E (String) +import Data.Text as E (Text) +import Data.Tree as E (Tree(..)) +import Data.Tuple as E (swap) +import Data.Typeable as E (Typeable) +import Data.Version as E (showVersion) +import Data.Void as E (Void) +import Data.Word as E (Word, Word32) +import Debug.Trace as E + ( trace + , traceIO + , traceId + , traceM + , traceShow + , traceShowId + , traceShowM + , traceStack + ) +import Foreign.ForeignPtr as E (ForeignPtr) +import Foreign.Storable as E (Storable) +import GHC.Exts as E (Constraint) +import Prelude as E + ( ($) + , ($!) + , (&&) + , (++) + , (.) + , (<$>) + , Bounded(..) + , Double + , Enum(..) + , Eq(..) + , Float + , Floating(..) + , Foldable + , Fractional(..) + , Integer + , Integral(..) + , Num(..) + , Ord(..) + , RealFloat(..) + , RealFrac(..) + , Show(..) + , Traversable + , (^) + , and + , any + , const + , curry + , error + , flip + , foldl + , foldr + , foldr1 + , fromIntegral + , fst + , head + , id + , map + , not + , or + , otherwise + , print + , putStr + , putStrLn + , realToFrac + , reverse + , seq + , snd + , subtract + , traverse + , uncurry + , undefined + , (||) + ) +import System.IO as E (IO, hFlush, stdout) +import Text.Read as E (readMaybe) diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs index cfaed43..fcfe303 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -1,21 +1,15 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Brittany.Internal.PreludeUtils where - - -import Prelude +import Control.Applicative +import Control.DeepSeq (NFData, force) +import Control.Exception.Base (evaluate) +import Control.Monad import qualified Data.Strict.Maybe as Strict import Debug.Trace -import Control.Monad +import Prelude 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) @@ -30,12 +24,12 @@ instance Alternative Strict.Maybe where x <|> Strict.Nothing = x _ <|> x = x -traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +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 + traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y (<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) = flip (<$!>) @@ -51,10 +45,10 @@ printErr = putStrErrLn . show errorIf :: Bool -> a -> a errorIf False = id -errorIf True = error "errorIf" +errorIf True = error "errorIf" errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id +errorIfNote Nothing = id errorIfNote (Just x) = error x (<&>) :: Functor f => f a -> (a -> b) -> f b diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index ca79995..1fd3eb7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -9,25 +9,18 @@ module Language.Haskell.Brittany.Internal.Transformations.Alt where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Memo as Memo import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.HList.ContainsType import qualified Data.List.Extra import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified GHC.OldList as List - -import Data.HList.ContainsType - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Control.Monad.Memo as Memo - - +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils data AltCurPos = AltCurPos { _acp_line :: Int -- chars in the current line @@ -35,7 +28,7 @@ data AltCurPos = AltCurPos , _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_forceMLFlag :: AltLineModeState } - deriving (Show) + deriving Show data AltLineModeState = AltLineModeStateNone @@ -46,17 +39,19 @@ data AltLineModeState deriving (Show) altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = + AltLineModeStateContradiction altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone -altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = + AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of @@ -81,7 +76,7 @@ transformAlts = . Memo.startEvalMemoT . fmap unwrapBriDocNumbered . rec - where + where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) -- transWrap :: BriDoc -> BriDocNumbered @@ -119,224 +114,246 @@ transformAlts = - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered - rec bdX@(brDcId, brDc) = do - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> - reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> - reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp - { _acp_indent = ind - , _acp_indentPrep = 0 - } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' - { _acp_line = ind - , _acp_indent = ind - } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( hasSpace1 lconf acp vs && lineCheck vs, bd)) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ]) - $ zip [1..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let lineCheck (VerticalSpacing _ p _) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( any (hasSpace2 lconf acp) vs - && any lineCheck vs, bd)) - let checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do - mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l:lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp - { _acp_line = ind - , _acp_indent = ind - } - rec x - return $ reWrap $ BDFLines (l':lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + rec + :: BriDocNumbered + -> Memo.MemoT + Int + [VerticalSpacing] + (MultiRWSS.MultiRWS r w (AltCurPos ': s)) + BriDocNumbered + rec bdX@(brDcId, brDc) = do + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let + indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd + mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } + sameLine' <- rec sameLine + mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- + mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let + lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (hasSpace1 lconf acp vs && lineCheck vs, bd) + ) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust + (\(_i :: Int, (b, x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ] + ) + $ zip [1 ..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let + lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) + ) + let + checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp + { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp + } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet $ acp + { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp + } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l : lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } + rec x + return $ reWrap $ BDFLines (l' : lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> + reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing _ bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess + $ "transformAlts: BDFDEBUG " + ++ s + ++ " (node-id=" + ++ show brDcId + ++ "): acp=" + ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 + :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + + sameLine + <= confUnpack (_lconfig_cols lconf) + && indent + + indentPrep + + par + <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) getSpacing :: forall m @@ -353,10 +370,11 @@ getSpacing !bridoc = rec bridoc -- BDWrapAnnKey _annKey bd -> rec bd BDFEmpty -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> - return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False - BDFSeq list -> - sumVs <$> rec `mapM` list + BDFLit t -> return $ LineModeValid $ VerticalSpacing + (Text.length t) + VerticalSpacingParNone + False + BDFSeq list -> sumVs <$> rec `mapM` list BDFCols _sig list -> sumVs <$> rec `mapM` list BDFSeparator -> return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False @@ -364,22 +382,28 @@ getSpacing !bridoc = rec bridoc mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParSome i -> + VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j } BDFBaseYPushCur bd -> do @@ -390,11 +414,13 @@ getSpacing !bridoc = rec bridoc -- the reason is that we really want to _keep_ it Just if it is -- just so we properly communicate the is-multiline fact. -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) , _vs_paragraph = VerticalSpacingParSome 0 } BDFBaseYPop bd -> rec bd @@ -408,86 +434,104 @@ getSpacing !bridoc = rec bridoc | VerticalSpacing lsp mPsp _ <- mVs , indSp <- mIndSp , lineMax <- getMaxVS $ mIndSp - , let pspResult = case mPsp of - VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax - , let parFlagResult = mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp + , let + pspResult = case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp lineMax + , let + parFlagResult = + mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp ] BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> do + BDFAlt (alt : _) -> rec alt + BDFForceMultiline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> LineModeInvalid - _ -> mVs + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> mVs - _ -> LineModeInvalid + _ -> LineModeInvalid BDFForwardLineMode bd -> rec bd BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return - $ LineModeValid - $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_:_) -> do + BDFLines [] -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_ : _) -> do lSps <- rec `mapM` ls - let (mVs:_) = lSps -- separated into let to avoid MonadFail - return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] + let (mVs : _) = lSps -- separated into let to avoid MonadFail + return + $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] BDFEnsureIndent indent bd -> do mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf BDFNonBottomSpacing b bd -> do mVs <- rec bd - return - $ mVs - <|> LineModeValid - (VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) + return $ mVs <|> LineModeValid + (VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } BDFForceParSpacing bd -> do mVs <- rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] BDFDebug s bd -> do r <- rec bd - tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r + tellDebugMess + $ "getSpacing: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): mVs=" + ++ show r return r return result - maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs = foldl' - (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing (max x1 y1) (case (x2, y2) of + (liftM2 + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> @@ -497,9 +541,14 @@ getSpacing !bridoc = rec bridoc (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> VerticalSpacingParAlways $ max i j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) False)) + VerticalSpacingParSome $ max x y + ) + False + ) + ) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing sumVs sps = foldl' (liftM2 go) initial sps where go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing @@ -508,18 +557,19 @@ getSpacing !bridoc = rec bridoc (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y) + VerticalSpacingParSome $ x + y + ) x3 singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False + singleline _ = False isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False + isPar _ = False parFlag = case sps of [] -> True _ -> all singleline (List.init sps) && isPar (List.last sps) @@ -539,374 +589,395 @@ getSpacings -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where + where -- when we do `take K . filter someCondition` on a list of spacings, we -- need to first (also) limit the size of the input list, otherwise a -- _large_ input with a similarly _large_ prefix not passing our filtering -- process could lead to exponential runtime behaviour. -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3*limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let specialCompare vs1 vs2 = - if ( (_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let allowHangingQuasiQuotes = - config - & _conf_layout - & _lconfig_allowHangingQuasiQuotes - & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit - $ [ (x,y) - | x<-mVss - , y<-indSps - ] - return $ mVsIndSp <&> - \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp) - ( mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> - return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1 ] -> VerticalSpacing - (Text.length t1) - VerticalSpacingParNone - False - (t1 : _) -> VerticalSpacing - (Text.length t1) - (VerticalSpacingParAlways 0) - True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_:_) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let worbled = fmap reverse - $ sequence - $ reverse - $ lSpss - sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - sumF [] = error $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then [VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) - return r - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3 * limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec + :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let + hasOkColCount (VerticalSpacing lsp psp _) = + lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let + specialCompare vs1 vs2 = + if ((_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let + allowHangingQuasiQuotes = + config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = + take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . specialNub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return + $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFSeparator -> + return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> + VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] + return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) - False) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp + ) + (mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return + $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1] -> + VerticalSpacing (Text.length t1) VerticalSpacingParNone False + (t1 : _) -> VerticalSpacing + (Text.length t1) + (VerticalSpacingParAlways 0) + True + | allowHangingQuasiQuotes + ] + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> + return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_ : _) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- map filterAndLimit <$> rec `mapM` ls + let + worbled = fmap reverse $ sequence $ reverse $ lSpss + sumF lSps@(lSp1 : _) = + VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False + sumF [] = + error + $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. + mVs <- rec bd + return $ if null mVs + then + [ VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] + else mVs <&> \vs -> vs + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess + $ "getSpacings: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): vs=" + ++ show (take 9 r) + return r + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y + ) + False + ) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y + ) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i fixIndentationForMultiple :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int fixIndentationForMultiple acp indent = do indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i + let + indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i -- for IndentPolicyMultiple, we restrict the amount of added -- indentation in such a manner that we end up on a multiple of the -- base indentation. indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack pure $ if indPolicy == IndentPolicyMultiple then - let indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 + let + indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 89a2c6f..5229134 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -3,16 +3,10 @@ module Language.Haskell.Brittany.Internal.Transformations.Columns where - - -import Language.Haskell.Brittany.Internal.Prelude -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types - import qualified Data.Generics.Uniplate.Direct as Uniplate - - +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types transformSimplifyColumns :: BriDoc -> BriDoc transformSimplifyColumns = Uniplate.rewrite $ \case @@ -20,118 +14,150 @@ transformSimplifyColumns = Uniplate.rewrite $ \case -- BDWrapAnnKey annKey $ transformSimplify bd BDEmpty -> Nothing BDLit{} -> Nothing - BDSeq list | any (\case BDSeq{} -> True - BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) - | all (\case BDSeparator -> True; _ -> False) rest -> - Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) - BDLines lines | any (\case BDLines{} -> True - BDEmpty{} -> True - _ -> False) lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDSeq list + | any + (\case + BDSeq{} -> True + BDEmpty{} -> True + _ -> False + ) + list + -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_ : _) : rest) + | all + (\case + BDSeparator -> True + _ -> False + ) + rest + -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)]) + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l x -> [x] -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) -- post floating in BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] -- ensureIndent float-in -- not sure if the following rule is necessary; tests currently are -- unaffected. -- BDEnsureIndent indent (BDLines lines) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines -- matching col special transformation - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) - | sig1==sig2 -> - Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) + | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- | sig1==sig2 -> -- Just $ BDPar -- ind1 -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 (List.init cols ++ [line]) + BDCols sig1 cols + | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 + -> Just + $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] + BDCols sig1 cols + | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 + $ List.init cols + ++ [BDPar ind line (BDLines $ List.init lines)] , BDCols sig2 cols2 ] - BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] - , BDCols sig2 cols2 - ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing BDForceSingleline{} -> Nothing BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing + BDExternal{} -> Nothing + BDPlain{} -> Nothing + BDLines{} -> Nothing BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing + BDDebug{} -> Nothing BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 0231306..c320dbf 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -3,25 +3,20 @@ module Language.Haskell.Brittany.Internal.Transformations.Floating where - - +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate - - +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils -- note that this is not total, and cannot be with that exact signature. mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = + BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" transformSimplifyFloating :: BriDoc -> BriDoc @@ -31,169 +26,192 @@ transformSimplifyFloating = stepBO .> stepFull -- better complexity. -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> - Just x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> - Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> - Just $ x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just + $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + BDAddBaseY BrIndentNone x -> Just x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + BDAddBaseY BrIndentNone x -> Just $ x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 7f7d7e5..9596e5b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -3,16 +3,10 @@ module Language.Haskell.Brittany.Internal.Transformations.Indent where - - -import Language.Haskell.Brittany.Internal.Prelude -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types - import qualified Data.Generics.Uniplate.Direct as Uniplate - - +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types -- prepare layouting by translating BDPar's, replacing them with Indents and -- floating those in. This gives a more clear picture of what exactly is @@ -31,15 +25,17 @@ transformSimplifyIndent = Uniplate.rewrite $ \case -- [ BDAddBaseY ind x -- , BDEnsureIndent ind indented -- ] - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l - x -> [x] + x -> [x] BDLines [l] -> Just l BDAddBaseY i (BDAnnotationPrior k x) -> Just $ BDAnnotationPrior k (BDAddBaseY i x) @@ -53,4 +49,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY _ lit@BDLit{} -> Just lit - _ -> Nothing + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 305ee08..7fb4aff 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -3,14 +3,9 @@ module Language.Haskell.Brittany.Internal.Transformations.Par where - - import Language.Haskell.Brittany.Internal.Prelude - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Types - - +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils transformSimplifyPar :: BriDoc -> BriDoc transformSimplifyPar = transformUp $ \case @@ -24,25 +19,28 @@ transformSimplifyPar = transformUp $ \case BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs where go = (=<<) $ \case BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x -- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- BDPar BrIndentNone line indented -> -- Just $ BDLines [line, indented] BDEnsureIndent BrIndentNone x -> x - x -> x + x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 76b7735..41d809b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -12,31 +12,20 @@ module Language.Haskell.Brittany.Internal.Types where - - -import Language.Haskell.Brittany.Internal.Prelude import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data -import qualified Data.Strict.Maybe as Strict -import qualified Safe - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan ) - -import Language.Haskell.GHC.ExactPrint ( AnnKey ) -import Language.Haskell.GHC.ExactPrint.Types ( Anns ) - -import Language.Haskell.Brittany.Internal.Config.Types - -import Data.Generics.Uniplate.Direct as Uniplate - +import Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Kind as Kind - - +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint (AnnKey) +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Types (Anns) +import qualified Safe data PerItemConfig = PerItemConfig { _icd_perBinding :: Map String (CConfig Maybe) @@ -44,20 +33,26 @@ data PerItemConfig = PerItemConfig } deriving Data.Data.Data -type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] - '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] +type PPM + = MultiRWSS.MultiRWS + '[ Map ExactPrint.AnnKey ExactPrint.Anns + , PerItemConfig + , Config + , ExactPrint.Anns + ] + '[Text.Builder.Builder , [BrittanyError] , Seq String] + '[] -type PPMLocal = MultiRWSS.MultiRWS - '[Config, ExactPrint.Anns] - '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] +type PPMLocal + = MultiRWSS.MultiRWS + '[Config , ExactPrint.Anns] + '[Text.Builder.Builder , [BrittanyError] , Seq String] + '[] newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) data LayoutState = LayoutState - { _lstate_baseYs :: [Int] + { _lstate_baseYs :: [Int] -- ^ stack of number of current indentation columns -- (not number of indentations). , _lstate_curYOrAddNewline :: Either Int Int @@ -65,7 +60,7 @@ data LayoutState = LayoutState -- 1) number of chars in the current line. -- 2) number of newlines to be inserted before inserting any -- non-space elements. - , _lstate_indLevels :: [Int] + , _lstate_indLevels :: [Int] -- ^ stack of current indentation levels. set for -- any layout-affected elements such as -- let/do/case/where elements. @@ -78,14 +73,14 @@ data LayoutState = LayoutState -- on the first indented element have an -- annotation offset relative to the last -- non-indented element, which is confusing. - , _lstate_comments :: Anns - , _lstate_commentCol :: Maybe Int -- this communicates two things: + , _lstate_comments :: Anns + , _lstate_commentCol :: Maybe Int -- this communicates two things: -- firstly, that cursor is currently -- at the end of a comment (so needs -- newline before any actual content). -- secondly, the column at which -- insertion of comments started. - , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone + , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone -- writes (any non-spaces) in the -- current line. -- , _lstate_isNewline :: NewLineState @@ -115,14 +110,21 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels instance Show LayoutState where show state = "LayoutState" - ++ "{baseYs=" ++ show (_lstate_baseYs state) - ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) - ++ ",indLevels=" ++ show (_lstate_indLevels state) - ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) - ++ ",commentCol=" ++ show (_lstate_commentCol state) - ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) - ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) - ++ "}" + ++ "{baseYs=" + ++ show (_lstate_baseYs state) + ++ ",curYOrAddNewline=" + ++ show (_lstate_curYOrAddNewline state) + ++ ",indLevels=" + ++ show (_lstate_indLevels state) + ++ ",indLevelLinger=" + ++ show (_lstate_indLevelLinger state) + ++ ",commentCol=" + ++ show (_lstate_commentCol state) + ++ ",addSepSpace=" + ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" + ++ show (_lstate_commentNewlines state) + ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- -- newline, really. by special-casing @@ -223,14 +225,16 @@ data BrIndent = BrIndentNone | BrIndentSpecial Int deriving (Eq, Ord, Data.Data.Data, Show) -type ToBriDocM = MultiRWSS.MultiRWS - '[Config, Anns] -- reader - '[[BrittanyError], Seq String] -- writer - '[NodeAllocIndex] -- state +type ToBriDocM + = MultiRWSS.MultiRWS + '[Config , Anns] -- reader + '[[BrittanyError] , Seq String] -- writer + '[NodeAllocIndex] -- state -type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c +type ToBriDoc (sym :: Kind.Type -> Kind.Type) + = Located (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = Located sym -> ToBriDocM c data DocMultiLine = MultiLineNo @@ -338,21 +342,21 @@ type BriDocFInt = BriDocF ((,) Int) type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list ) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts ) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x + uniplate (BDAlt alts) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = @@ -361,83 +365,84 @@ instance Uniplate.Uniplate BriDoc where plate BDAnnotationRest |- annKey |* bd uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines ) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDLines lines) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd + uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int -- TODO: rename to "dropLabels" ? unwrapBriDocNumbered :: BriDocNumbered -> BriDoc unwrapBriDocNumbered tpl = case snd tpl of - BDFEmpty -> BDEmpty - BDFLit t -> BDLit t - BDFSeq list -> BDSeq $ rec <$> list - BDFCols sig list -> BDCols sig $ rec <$> list - BDFSeparator -> BDSeparator - BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDFBaseYPop bd -> BDBaseYPop $ rec bd - BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDFPar ind line indented -> BDPar ind (rec line) (rec indented) - BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDFForwardLineMode bd -> BDForwardLineMode $ rec bd - BDFExternal k ks c t -> BDExternal k ks c t - BDFPlain t -> BDPlain t + BDFEmpty -> BDEmpty + BDFLit t -> BDLit t + BDFSeq list -> BDSeq $ rec <$> list + BDFCols sig list -> BDCols sig $ rec <$> list + BDFSeparator -> BDSeparator + BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDFBaseYPop bd -> BDBaseYPop $ rec bd + BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDFPar ind line indented -> BDPar ind (rec line) (rec indented) + BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDFForwardLineMode bd -> BDForwardLineMode $ rec bd + BDFExternal k ks c t -> BDExternal k ks c t + BDFPlain t -> BDPlain t BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd - BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd - BDFLines lines -> BDLines $ rec <$> lines - BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd + BDFLines lines -> BDLines $ rec <$> lines + BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False -isNotEmpty _ = True +isNotEmpty _ = True -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd - BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDPlain{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd + BDPar _ind line indented -> + briDocSeqSpine line `seq` briDocSeqSpine indented + BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDPlain{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd @@ -456,18 +461,19 @@ data VerticalSpacingPar -- product like (Normal|Always, None|Some Int). deriving (Eq, Show) -data VerticalSpacing - = VerticalSpacing - { _vs_sameLine :: !Int - , _vs_paragraph :: !VerticalSpacingPar - , _vs_parFlag :: !Bool - } +data VerticalSpacing = VerticalSpacing + { _vs_sameLine :: !Int + , _vs_paragraph :: !VerticalSpacingPar + , _vs_parFlag :: !Bool + } deriving (Eq, Show) newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) deriving (Functor, Applicative, Monad, Show, Alternative) -pattern LineModeValid :: forall t. t -> LineModeValidity t -pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t -pattern LineModeInvalid :: forall t. LineModeValidity t -pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t +pattern LineModeValid :: forall t . t -> LineModeValidity t +pattern LineModeValid x = + LineModeValidity (Strict.Just x) :: LineModeValidity t +pattern LineModeInvalid :: forall t . LineModeValidity t +pattern LineModeInvalid = + LineModeValidity Strict.Nothing :: LineModeValidity t diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index a12f7ea..a52caa4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -7,40 +7,29 @@ module Language.Haskell.Brittany.Internal.Utils where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Data.ByteString as B import qualified Data.Coerce +import Data.Data +import Data.Generics.Aliases +import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq +import DataTreePrint +import qualified GHC.Data.FastString as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Hs.Extension as HsExtension import qualified GHC.OldList as List - +import GHC.Types.Name.Occurrence as OccName (occNameString) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Outputable as GHC +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - -import Data.Data -import Data.Generics.Aliases - import qualified Text.PrettyPrint as PP -import qualified GHC.Utils.Outputable as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Data.FastString as GHC -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.Name.Occurrence as OccName ( occNameString ) -import qualified Data.ByteString as B - -import DataTreePrint - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.Hs.Extension as HsExtension - - - parDoc :: String -> PP.Doc parDoc = PP.fsep . fmap PP.text . List.words @@ -55,7 +44,8 @@ showOutputable :: (GHC.Outputable a) => a -> String showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y +fromMaybeIdentity x y = + Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity x y = @@ -70,24 +60,26 @@ instance (Num a, Ord a) => Semigroup (Max a) where (<>) = Data.Coerce.coerce (max :: a -> a -> a) instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 + mempty = Max 0 mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data -instance Show ShowIsId where show (ShowIsId x) = x +instance Show ShowIsId where + show (ShowIsId x) = x -data A x = A ShowIsId x deriving Data +data A x = A ShowIsId x + deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -95,18 +87,22 @@ customLayouterF anns layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter + srcSpan ss = + simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" ++ showOutputable ss ++ "}" + $ "{" + ++ showOutputable ss + ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where @@ -118,12 +114,12 @@ customLayouterF anns layoutF = customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -131,14 +127,15 @@ customLayouterNoAnnsF layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter @@ -202,12 +199,11 @@ traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () -tellDebugMess :: MonadMultiWriter - (Seq String) m => String -> m () +tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s -tellDebugMessShow :: forall a m . (MonadMultiWriter - (Seq String) m, Show a) => a -> m () +tellDebugMessShow + :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. @@ -222,29 +218,28 @@ briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) +annsDoc = + printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1:aR) = case fn a1 of - Left b -> (b : bs, cs) +breakEither _ [] = ([], []) +breakEither fn (a1 : aR) = case fn a1 of + Left b -> (b : bs, cs) Right c -> (bs, c : cs) - where - (bs, cs) = breakEither fn aR + where (bs, cs) = breakEither fn aR spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) - where - (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) +spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) + where (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) data FirstLastView a = FirstLastEmpty @@ -254,7 +249,7 @@ data FirstLastView a splitFirstLast :: [a] -> FirstLastView a splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) +splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) -- TODO: move to uniplate upstream? -- aka `transform` @@ -273,7 +268,7 @@ lines' :: String -> [String] lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] - (s1, (_:r)) -> s1 : lines' r + (s1, (_ : r)) -> s1 : lines' r absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index 87ebe66..7f22f11 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -4,58 +4,41 @@ module Language.Haskell.Brittany.Main where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Control.Monad (zipWithM) import qualified Control.Monad.Trans.Except as ExceptT +import Data.CZipWith import qualified Data.Either import qualified Data.List.Extra +import qualified Data.Monoid import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy as TextL +import DataTreePrint +import GHC (GenLocated(L)) +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List -import qualified System.IO - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Data.Monoid - -import GHC ( GenLocated(L) ) -import GHC.Utils.Outputable ( Outputable(..) - , showSDocUnsafe - ) - -import Text.Read ( Read(..) ) -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec - -import Control.Monad ( zipWithM ) -import Data.CZipWith - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Obfuscation - -import qualified Text.PrettyPrint as PP - -import DataTreePrint -import UI.Butcher.Monadic - +import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Obfuscation +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Paths_brittany +import qualified System.Directory as Directory import qualified System.Exit -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Paths_brittany - - +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.PrettyPrint as PP +import Text.Read (Read(..)) +import UI.Butcher.Monadic data WriteMode = Display | Inplace @@ -110,7 +93,7 @@ helpDoc = PP.vcat $ List.intersperse ] , parDoc $ "See https://github.com/lspitzner/brittany" , parDoc - $ "Please report bugs at" + $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" ] @@ -147,15 +130,16 @@ mainCmdParser helpDesc = do addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser + configPaths <- addFlagStringParams + "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] @@ -181,7 +165,7 @@ mainCmdParser helpDesc = do "" ["write-mode"] "(display|inplace)" - ( flagHelp + (flagHelp (PP.vcat [ PP.text "display: output for any input(s) goes to stdout" , PP.text "inplace: override respective input file (without backup!)" @@ -211,11 +195,13 @@ mainCmdParser helpDesc = do $ ppHelpShallow helpDesc System.Exit.exitSuccess - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths + let + inputPaths = + if null inputParams then [Nothing] else map Just inputParams + let + outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths configsToLoad <- liftIO $ if null configPaths then @@ -230,14 +216,15 @@ mainCmdParser helpDesc = do ) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x + Just x -> return x when (config & _conf_debug & _dconf_dump_config & confUnpack) $ trace (showConfigYaml config) $ return () - results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths + results <- zipWithM + (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths if checkMode then when (Changes `elem` (Data.Either.rights results)) @@ -266,58 +253,65 @@ coreIO -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let + putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let ghcOptions = config & _conf_forward & _options_ghc & runIdentity -- there is a good of code duplication between the following code and the -- `pureModuleTransform` function. Unfortunately, there are also a good -- amount of slight differences: This module is a bit more verbose, and -- it tries to use the full-blown `parseModule` function which supports -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack -- the flag will do the following: insert a marker string -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- "#include" before processing (parsing) input; and remove that marker -- string from the transformation output. -- The flag is intentionally misspelled to prevent clashing with -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + let + hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let + exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id + let + hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let + hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id inputString <- liftIO System.IO.getContents - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) + parseRes <- liftIO $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) return (parseRes, Text.pack inputString) Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc + parseRes <- parseModule ghcOptions p cppCheckFunc inputText <- Text.IO.readFile p -- The above means we read the file twice, but the -- GHC API does not really expose the source it @@ -346,10 +340,12 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = pure c let moduleConf = cZipWith fromOptionIdentity config inlineConf when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + let + val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () - let disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack + let + disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack (errsWarns, outSText, hasChanges) <- do if | disableFormatting -> do @@ -358,46 +354,52 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let r = Text.pack $ ExactPrint.exactPrint parsedSource anns pure ([], r, r /= originalContents) | otherwise -> do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let + omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - else outRaw + else liftIO $ pPrintModuleAndCheck + moduleConf + perItemConf + anns + parsedSource + let + hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let + out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out pure $ (ews, out', out' /= originalContents) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 unless (null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns + let + groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns groupedErrsWarns `forM_` \case (ErrorOutputCheck{} : _) -> do putErrorLn - $ "ERROR: brittany pretty printer" + $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str @@ -406,9 +408,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ "WARNING: encountered unknown syntactical constructs:" uns `forM_` \case ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe + (ppr loc) when - ( config + (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack @@ -422,17 +425,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = putErrorLn $ "WARNINGS:" warns `forM_` \case LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" unused@(ErrorUnusedComment{} : _) -> do putErrorLn - $ "Error: detected unprocessed comments." + $ "Error: detected unprocessed comments." ++ " The transformation output will most likely" ++ " not contain some of the comments" ++ " present in the input haskell source file." putErrorLn $ "Affected are the following comments:" unused `forM_` \case ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" (ErrorMacroConfig err input : _) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err @@ -443,8 +446,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let hasErrors = if config & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) outputOnErrs = config & _conf_errorHandling @@ -459,10 +462,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ addTraceSep (_conf_debug config) $ case outputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges + Just p -> liftIO $ do + let + isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText when (checkMode && hasChanges) $ case inputPathM of @@ -474,15 +478,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = where addTraceSep conf = if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] then trace "----" else id diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 774088f..a39eecf 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -2,35 +2,24 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE ScopedTypeVariables #-} -import Language.Haskell.Brittany.Internal.Prelude +import Data.Coerce (coerce) +import Data.List (groupBy) import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO import qualified GHC.OldList as List -import qualified System.Directory - -import Test.Hspec - -import qualified Text.Parsec as Parsec -import Text.Parsec.Text ( Parser ) - -import Data.List ( groupBy ) - -import Language.Haskell.Brittany.Internal - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config - -import Data.Coerce ( coerce ) - -import qualified Data.Text.IO as Text.IO -import System.FilePath ( () ) - -import System.Timeout ( timeout ) - - - +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified System.Directory +import System.FilePath (()) +import System.Timeout (timeout) +import Test.Hspec +import qualified Text.Parsec as Parsec +import Text.Parsec.Text (Parser) hush :: Either a b -> Maybe b hush = either (const Nothing) Just @@ -40,32 +29,32 @@ hush = either (const Nothing) Just asymptoticPerfTest :: Spec asymptoticPerfTest = do it "10 do statements" - $ roundTripEqualWithTimeout 1500000 - $ (Text.pack "func = do\n") + $ roundTripEqualWithTimeout 1500000 + $ (Text.pack "func = do\n") <> Text.replicate 10 (Text.pack " statement\n") it "10 do nestings" - $ roundTripEqualWithTimeout 4000000 - $ (Text.pack "func = ") + $ roundTripEqualWithTimeout 4000000 + $ (Text.pack "func = ") <> mconcat - ( [1 .. 10] - <&> \(i :: Int) -> - (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") + ([1 .. 10] <&> \(i :: Int) -> + (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") ) <> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n" <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" it "10 AppOps" - $ roundTripEqualWithTimeout 1000000 - $ (Text.pack "func = expr") + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = expr") <> Text.replicate 10 (Text.pack "\n . expr") --TODO roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) + timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust) where - action = fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + action = fmap + (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) data InputLine @@ -85,10 +74,11 @@ data TestCase = TestCase main :: IO () main = do files <- System.Directory.listDirectory "data/" - let blts = - List.sort - $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt" `isSuffixOf`) files + let + blts = + List.sort + $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) + $ filter (".blt" `isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("data" blt) let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt" @@ -99,15 +89,17 @@ main = do it "gives properly formatted result for valid input" $ do let input = Text.pack $ unlines - ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] - let expected = Text.pack $ unlines - [ "func =" - , " [ 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " ]" - ] + [ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]" + ] + let + expected = Text.pack $ unlines + [ "func =" + , " [ 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " ]" + ] output <- liftIO $ parsePrintModule staticDefaultConfig input hush output `shouldBe` Just expected groups `forM_` \(groupname, tests) -> do @@ -154,30 +146,33 @@ main = do testProcessor = \case HeaderLine n : rest -> let normalLines = Data.Maybe.mapMaybe extractNormal rest - in TestCase - { testName = n - , isPending = any isPendingLine rest - , content = Text.unlines normalLines - } + in + TestCase + { testName = n + , isPending = any isPendingLine rest + , content = Text.unlines normalLines + } l -> - error $ "first non-empty line must start with #test footest\n" ++ show l + error + $ "first non-empty line must start with #test footest\n" + ++ show l extractNormal (NormalLine l) = Just l - extractNormal _ = Nothing + extractNormal _ = Nothing isPendingLine PendingLine{} = True - isPendingLine _ = False + isPendingLine _ = False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#group" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" + | _ <- Parsec.try $ Parsec.string "#group" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof + , _ <- Parsec.eof ] , [ HeaderLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#test" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" + | _ <- Parsec.try $ Parsec.string "#test" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof + , _ <- Parsec.eof ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" @@ -197,17 +192,17 @@ main = do ] lineMapper :: Text -> InputLine lineMapper line = case Parsec.runParser specialLineParser () "" line of - Left _e -> NormalLine line - Right l -> l + Left _e -> NormalLine line + Right l -> l lineIsSpace :: InputLine -> Bool lineIsSpace CommentLine = True - lineIsSpace _ = False + lineIsSpace _ = False grouperG :: InputLine -> InputLine -> Bool grouperG _ GroupLine{} = False - grouperG _ _ = True + grouperG _ _ = True grouperT :: InputLine -> InputLine -> Bool grouperT _ HeaderLine{} = False - grouperT _ _ = True + grouperT _ _ = True -------------------- @@ -225,43 +220,42 @@ instance Show PPTextWrapper where show (PPTextWrapper t) = "\n" ++ Text.unpack t -- brittany-next-binding --columns 160 --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } defaultTestConfig :: Config defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } - , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } + , _conf_preprocessor = _conf_preprocessor staticDefaultConfig + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config contextFreeTestConfig = defaultTestConfig { _conf_layout = (_conf_layout defaultTestConfig) - { _lconfig_indentPolicy = coerce IndentPolicyLeft - , _lconfig_alignmentLimit = coerce (1 :: Int) - , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } + { _lconfig_indentPolicy = coerce IndentPolicyLeft + , _lconfig_alignmentLimit = coerce (1 :: Int) + , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled + } } -- 2.30.2 From 4079981b1de020a462b296c069eff8f785299747 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 7 Nov 2021 12:37:49 +0000 Subject: [PATCH 454/478] Revert "Format Brittany with Brittany" This reverts commit 4398b5880d05340e31186c2460c300b6698dadd4. --- brittany.yaml | 5 - source/library/Language/Haskell/Brittany.hs | 14 +- .../Language/Haskell/Brittany/Internal.hs | 543 +++---- .../Haskell/Brittany/Internal/Backend.hs | 540 +++---- .../Haskell/Brittany/Internal/BackendUtils.hs | 318 ++-- .../Haskell/Brittany/Internal/Config.hs | 271 ++-- .../Haskell/Brittany/Internal/Config/Types.hs | 88 +- .../Internal/Config/Types/Instances.hs | 35 +- .../Brittany/Internal/ExactPrintUtils.hs | 172 +- .../Brittany/Internal/LayouterBasics.hs | 220 +-- .../Brittany/Internal/Layouters/DataDecl.hs | 404 ++--- .../Brittany/Internal/Layouters/Decl.hs | 990 ++++++------ .../Brittany/Internal/Layouters/Expr.hs | 1233 +++++++------- .../Brittany/Internal/Layouters/Expr.hs-boot | 13 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 149 +- .../Brittany/Internal/Layouters/Import.hs | 203 ++- .../Brittany/Internal/Layouters/Module.hs | 128 +- .../Brittany/Internal/Layouters/Pattern.hs | 109 +- .../Brittany/Internal/Layouters/Stmt.hs | 52 +- .../Brittany/Internal/Layouters/Stmt.hs-boot | 11 +- .../Brittany/Internal/Layouters/Type.hs | 448 +++--- .../Haskell/Brittany/Internal/Obfuscation.hs | 30 +- .../Haskell/Brittany/Internal/Prelude.hs | 537 ++++--- .../Haskell/Brittany/Internal/PreludeUtils.hs | 26 +- .../Brittany/Internal/Transformations/Alt.hs | 1411 ++++++++--------- .../Internal/Transformations/Columns.hs | 208 ++- .../Internal/Transformations/Floating.hs | 378 +++-- .../Internal/Transformations/Indent.hs | 32 +- .../Brittany/Internal/Transformations/Par.hs | 40 +- .../Haskell/Brittany/Internal/Types.hs | 266 ++-- .../Haskell/Brittany/Internal/Utils.hs | 145 +- .../library/Language/Haskell/Brittany/Main.hs | 296 ++-- source/test-suite/Main.hs | 182 ++- 33 files changed, 4804 insertions(+), 4693 deletions(-) delete mode 100644 brittany.yaml diff --git a/brittany.yaml b/brittany.yaml deleted file mode 100644 index fba01fd..0000000 --- a/brittany.yaml +++ /dev/null @@ -1,5 +0,0 @@ -conf_layout: - lconfig_cols: 79 - lconfig_columnAlignMode: - tag: ColumnAlignModeDisabled - lconfig_indentPolicy: IndentPolicyLeft diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs index a2726c8..8c225c6 100644 --- a/source/library/Language/Haskell/Brittany.hs +++ b/source/library/Language/Haskell/Brittany.hs @@ -16,9 +16,13 @@ module Language.Haskell.Brittany , CForwardOptions(..) , CPreProcessorConfig(..) , BrittanyError(..) - ) where + ) +where -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types + + + +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index f2f0fdc..71e885b 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -12,52 +12,68 @@ module Language.Haskell.Brittany.Internal , parseModuleFromString , extractCommentConfigs , getTopLevelDeclNameMap - ) where + ) +where -import Control.Monad.Trans.Except + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Char (isSpace) -import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Data.Yaml -import qualified GHC hiding (parseModule) -import GHC (GenLocated(L)) -import GHC.Data.Bag -import qualified GHC.Driver.Session as GHC -import GHC.Hs -import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.SrcLoc (SrcSpan) -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Indent -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint + +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified UI.Butcher.Monadic as Butcher + +import Control.Monad.Trans.Except +import Data.HList.HList +import qualified Data.Yaml +import Data.CZipWith +import qualified UI.Butcher.Monadic as Butcher + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.LayouterBasics + +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Backend +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import Language.Haskell.Brittany.Internal.Transformations.Alt +import Language.Haskell.Brittany.Internal.Transformations.Floating +import Language.Haskell.Brittany.Internal.Transformations.Par +import Language.Haskell.Brittany.Internal.Transformations.Columns +import Language.Haskell.Brittany.Internal.Transformations.Indent + +import qualified GHC + hiding ( parseModule ) +import GHC.Parser.Annotation ( AnnKeywordId(..) ) +import GHC ( GenLocated(L) + ) +import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Hs +import GHC.Data.Bag +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Data.Char ( isSpace ) + + data InlineConfigTarget = InlineConfigTargetModule @@ -75,36 +91,35 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do [ ( k , [ x | (ExactPrint.Comment x _ _, _) <- - (ExactPrint.annPriorComments ann + ( ExactPrint.annPriorComments ann ++ ExactPrint.annFollowingComments ann ) ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] ) | (k, ann) <- Map.toList anns ] - let - configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - (("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) + let configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + ( ("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) let configParser = Butcher.addAlternatives [ ( "commandline-config" @@ -123,44 +138,39 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do ] parser = do -- we will (mis?)use butcher here to parse the inline config -- line. - let - nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + let nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let - nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + let nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding - let - disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let - disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let - disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) + let disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do @@ -168,42 +178,41 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) Butcher.addNullCmd $ do bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser + conf <- configParser Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) conf <- configParser Butcher.addCmdImpl (InlineConfigTargetModule, conf) lineConfigss <- configLiness `forM` \(k, ss) -> do r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c + Left err -> Left $ (err, s) + Right c -> Right $ c pure (k, r) - let - perModule = foldl' - (<>) - mempty - [ conf - | (_, lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf) <- lineConfigs - ] + let perModule = foldl' + (<>) + mempty + [ conf + | (_ , lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf ) <- lineConfigs + ] let perBinding = Map.fromListWith (<>) [ (n, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs - , n <- case target of + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , n <- case target of InlineConfigTargetBinding s -> [s] - InlineConfigTargetNextBinding - | Just name <- Map.lookup k declNameMap -> [name] + InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> + [name] _ -> [] ] let perKey = Map.fromListWith (<>) [ (k, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs , case target of InlineConfigTargetNextDecl -> True InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> @@ -221,7 +230,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls + | decl <- decls , (name : _) <- [getDeclBindingNames decl] ] @@ -239,78 +248,70 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = -- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configWithDebugs inputText = runExceptT $ do - let - config = - configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let config = + configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack (anns, parsedSource, hasCPP) <- do - let - hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let - hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False parseResult <- lift $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x + Left err -> throwE [ErrorInput err] + Right x -> pure x (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting then do return inputText else do (errsWarns, outputTextL) <- do - let - omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack + let omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConfig perItemConf anns parsedSource else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let - hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews - , TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw + , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn + (TextL.pack "\n") + outRaw ) else (ews, outRaw) - let - customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let - hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack then not $ null errsWarns else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors @@ -330,27 +331,26 @@ pPrintModule -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf inlineConf anns parsedModule = - let - ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) + let ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do -- -- debugStrings `forM_` \s -> @@ -365,17 +365,15 @@ pPrintModuleAndCheck -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString - ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let - errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] + parseResult <- parseModuleFromString ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] return (errs', output) @@ -386,22 +384,18 @@ parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of - Left err -> - return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) + Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) Right (anns, parsedModule) -> runExceptT $ do (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) - of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x + case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let - omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (errs, ltext) <- if omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift @@ -411,13 +405,13 @@ parsePrintModuleTests conf filename input = do else let errStrs = errs <&> \case - ErrorInput str -> str + ErrorInput str -> str ErrorUnusedComment str -> str - LayoutWarning str -> str + LayoutWarning str -> str ErrorUnknownNode str _ -> str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs isErrorUnusedComment :: BrittanyError -> Bool isErrorUnusedComment x = case x of @@ -470,30 +464,27 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do let annKey = ExactPrint.mkAnnKey lmod post <- ppPreamble lmod decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl + let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let - mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk <&> \annMap -> - Map.union (Map.findWithDefault Map.empty annKey annMap) - $ Map.findWithDefault Map.empty declAnnKey annMap + let mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk + <&> \annMap -> + Map.union (Map.findWithDefault Map.empty annKey annMap) $ + Map.findWithDefault Map.empty declAnnKey annMap - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns config <- mAsk - let - config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + let config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) - let - exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do bd <- if exactprintOnly then briDocMToPPM $ briDocByExactNoComment decl @@ -506,34 +497,33 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd - let - finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post + let finalComments = filter + (fst .> \case + ExactPrint.AnnComment{} -> True + _ -> False + ) + post post `forM_` \case (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let - folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> - ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] + _ -> [] -- Prints the information associated with the module annotation @@ -550,9 +540,8 @@ ppPreamble lmod@(L loc m@HsModule{}) = do -- attached annotations that come after the module's where -- from the module node config <- mAsk - let - shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + let shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack let (filteredAnns', post) = @@ -562,23 +551,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do let modAnnsDp = ExactPrint.annsDP mAnn isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False + isWhere _ = False isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp (pre, post') = case (whereInd, eofInd) of (Nothing, Nothing) -> ([], modAnnsDp) - (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) - (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in (filteredAnns'', post') - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations + in + (filteredAnns'', post') + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns' if shouldReformatPreamble @@ -587,7 +576,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule return post _sigHead :: Sig GhcPs -> String @@ -600,7 +589,7 @@ _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" @@ -618,67 +607,63 @@ layoutBriDoc briDoc = do transformAlts briDoc >>= mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt -- bridoc transformation: float stuff in mGet >>= transformSimplifyFloating .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf - "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating + .> traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating -- bridoc transformation: par removal mGet >>= transformSimplifyPar .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par -- bridoc transformation: float stuff in mGet >>= transformSimplifyColumns .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns -- bridoc transformation: indent mGet >>= transformSimplifyIndent .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl anns :: ExactPrint.Anns <- mAsk - let - state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } + let state = LayoutState { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - let - remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] + let remainingComments = + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs index 0dfa6d6..142fe2f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -6,6 +6,10 @@ module Language.Haskell.Brittany.Internal.Backend where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.State.Strict as StateS import qualified Data.Either as Either import qualified Data.Foldable as Foldable @@ -17,32 +21,32 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -type ColIndex = Int +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + + +import qualified Data.Text.Lazy.Builder as Text.Builder + + + +type ColIndex = Int data ColumnSpacing = ColumnSpacingLeaf Int | ColumnSpacingRef Int Int -type ColumnBlock a = [a] +type ColumnBlock a = [a] type ColumnBlocks a = Seq [a] -type ColMap1 - = IntMapL.IntMap {- ColIndex -} - (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 - = IntMapL.IntMap {- ColIndex -} - (Float, ColumnBlock Int, ColumnBlocks Int) +type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) -- (ratio of hasSpace, maximum, raw) data ColInfo @@ -52,23 +56,20 @@ data ColInfo instance Show ColInfo where show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = - "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = - "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") + show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list data ColBuildState = ColBuildState { _cbs_map :: ColMap1 , _cbs_index :: ColIndex } -type LayoutConstraints m - = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) +type LayoutConstraints m = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM = \case @@ -89,11 +90,10 @@ layoutBriDocM = \case BDSeparator -> do layoutAddSepSpace BDAddBaseY indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ layoutBriDocM bd BDBaseYPushCur bd -> do layoutBaseYPushCur @@ -108,39 +108,36 @@ layoutBriDocM = \case layoutBriDocM bd layoutIndentLevelPop BDEnsureIndent indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteEnsureBlock layoutBriDocM bd BDPar indent sameLine indented -> do layoutBriDocM sameLine - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteNewlineBlock layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt : _) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt:_) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd BDExternal annKey subKeys shouldAddComment t -> do - let - tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines + let tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines anns :: ExactPrint.Anns <- mAsk when shouldAddComment $ do layoutWriteAppend - $ Text.pack - $ "{-" + $ Text.pack + $ "{-" ++ show (annKey, Map.lookup annKey anns) ++ "-}" zip [1 ..] tlines `forM_` \(i, l) -> do @@ -157,10 +154,9 @@ layoutBriDocM = \case BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let - moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey + let moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -171,8 +167,8 @@ layoutBriDocM = \case } return mAnn case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace priors @@ -180,10 +176,9 @@ layoutBriDocM = \case when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y @@ -195,20 +190,18 @@ layoutBriDocM = \case layoutBriDocM bd mComments <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let - mToSpan = case mAnn of - Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> - Just annR - _ -> Nothing + let mToSpan = case mAnn of + Just anns | Maybe.isNothing keyword -> Just anns + Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just + annR + _ -> Nothing case mToSpan of Just anns -> do - let - (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing + let (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing mSet $ state { _lstate_comments = Map.adjust (\ann -> ann { ExactPrint.annsDP = rest }) @@ -220,19 +213,17 @@ layoutBriDocM = \case case mComments of Nothing -> pure () Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd @@ -241,26 +232,21 @@ layoutBriDocM = \case let m = _lstate_comments state pure $ Map.lookup annKey m let mComments = nonEmpty . extractAllComments =<< annMay - let - semiCount = length - [ () - | Just ann <- [annMay] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- - mAsk - <&> _conf_layout - .> _lconfig_experimentalSemicolonNewlines - .> confUnpack + let semiCount = length [ () + | Just ann <- [ annMay ] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- mAsk <&> + _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack mModify $ \state -> state { _lstate_comments = Map.adjust - (\ann -> ann - { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } + ( \ann -> ann { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = + flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } ) annKey (_lstate_comments state) @@ -268,40 +254,37 @@ layoutBriDocM = \case case mComments of Nothing -> do when shouldAddSemicolonNewlines $ do - [1 .. semiCount] `forM_` const layoutWriteNewline + [1..semiCount] `forM_` const layoutWriteNewline Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#' : _) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack comment + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) 1 + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let - relevant = - [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] + let relevant = [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] case relevant of [] -> pure Nothing - (ExactPrint.Types.DP (y, x) : _) -> do + (ExactPrint.Types.DP (y, x):_) -> do mSet state { _lstate_commentNewlines = 0 } pure $ Just (y - _lstate_commentNewlines state, x) case mDP of @@ -312,8 +295,8 @@ layoutBriDocM = \case layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" layoutBriDocM bd @@ -324,73 +307,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc -- appended at the current position. where rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc where rec :: BriDoc -> Bool rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_] -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= @@ -475,16 +458,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe 0 (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack case () of _ -> do -- tellDebugMess ("processedMap: " ++ show processedMap) sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos <&> processInfo colMax processedMap where (colInfos, finalState) = @@ -501,41 +484,40 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do where alignMax' = max 0 alignMax processedMap :: ColMap2 - processedMap = fix $ \result -> - _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + processedMap = + fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> let colss = colSpacingss <&> \spss -> case reverse spss of [] -> [] - (xN : xR) -> - reverse - $ (if lastFlag then fLast else fInit) xN - : fmap fInit xR + (xN:xR) -> + reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR where - fLast (ColumnSpacingLeaf len) = len + fLast (ColumnSpacingLeaf len ) = len fLast (ColumnSpacingRef len _) = len fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of - Nothing -> 0 + fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of + Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} fmap colAggregation $ transpose $ Foldable.toList colss (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols counter count l = if List.last posXs + List.last l <= colMax then count + 1 else count ratio = fromIntegral (foldl counter (0 :: Int) colss) / fromIntegral (length colss) - in (ratio, maxCols, colss) + in + (ratio, maxCols, colss) mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd : bdr) = do - info <- mergeInfoBriDoc True lastInfo bd + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd:bdr) = do + info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info) @@ -563,27 +545,28 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- personal preference to not break alignment for those, even if -- multiline. Really, this should be configurable.. (TODO) shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True + shouldBreakAfter bd = alignBreak && + briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp{} _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True mergeInfoBriDoc :: Bool @@ -591,22 +574,23 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -> BriDoc -> StateS.StateT ColBuildState Identity ColInfo mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs -> do + | infoSig == colSig && length subLengthsInfos == length subDocs + -> do let isLastList = if lastFlag - then (== length subDocs) <$> [1 ..] + then (==length subDocs) <$> [1 ..] else repeat False infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs + let curLengths = briDocLineLength <$> subDocs let trueSpacings = getTrueSpacings (zip curLengths infos) do -- update map s <- StateS.get - let m = _cbs_map s + let m = _cbs_map s let (Just (_, spaces)) = IntMapS.lookup infoInd m StateS.put s { _cbs_map = IntMapS.insert @@ -615,17 +599,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do m } return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise -> briDocToColInfo lastFlag brdc + | otherwise + -> briDocToColInfo lastFlag brdc brdc -> return $ ColInfoNo brdc briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo lastFlag = \case BDCols sig list -> withAlloc lastFlag $ \ind -> do - let - isLastList = - if lastFlag then (== length list) <$> [1 ..] else repeat False + let isLastList = + if lastFlag then (==length list) <$> [1 ..] else repeat False subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos + let lengthInfos = zip (briDocLineLength <$> list) subInfos let trueSpacings = getTrueSpacings lengthInfos return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) bd -> return $ ColInfoNo bd @@ -633,11 +617,11 @@ briDocToColInfo lastFlag = \case getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings lengthInfos = lengthInfos <&> \case (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _) -> ColumnSpacingLeaf len + (len, _ ) -> ColumnSpacingLeaf len withAlloc :: Bool - -> ( ColIndex + -> ( ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) ) -> StateS.State ColBuildState ColInfo @@ -652,14 +636,13 @@ withAlloc lastFlag f = do processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ do colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMode <- - mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do + alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack + curX <- do state <- mGet -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state @@ -671,11 +654,10 @@ processInfo maxSpace m = \case let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let - maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l + let maxCols2 = list <&> \case + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l let maxCols = zipWith max maxCols1 maxCols2 let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols -- handle the cases that the vertical alignment leads to more than max @@ -686,48 +668,46 @@ processInfo maxSpace m = \case -- sizes in such a way that it works _if_ we have sizes (*factor) -- in each column. but in that line, in the last column, we will be -- forced to occupy the full vertical space, not reduced by any factor. - let - fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (* factor) .> truncate - _ -> posXs - let - spacings = - zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs + let fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (*factor) .> truncate + _ -> posXs + let spacings = zipWith (-) + (List.tail fixedPosXs ++ [min maxX colMax]) + fixedPosXs -- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let - alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct + let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. + then noAlignAct + else alignAct case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct processInfoIgnore :: LayoutConstraints m => ColInfo -> m () processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index e48da84..6c34ea9 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -3,29 +3,42 @@ module Language.Haskell.Brittany.Internal.BackendUtils where + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Either import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (Located) import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -traceLocal :: (MonadMultiState LayoutState m) => a -> m () +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey + , Annotation + ) + +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.Brittany.Internal.Utils + +import GHC ( Located ) + + + +traceLocal + :: (MonadMultiState LayoutState m) + => a + -> m () traceLocal _ = return () layoutWriteAppend - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Text -> m () layoutWriteAppend t = do @@ -41,13 +54,15 @@ layoutWriteAppend t = do mTell $ Text.Builder.fromText $ t mModify $ \s -> s { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces , _lstate_addSepSpace = Nothing } layoutWriteAppendSpaces - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () layoutWriteAppendSpaces i = do @@ -55,18 +70,20 @@ layoutWriteAppendSpaces i = do unless (i == 0) $ do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state + { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state } layoutWriteAppendMultiline - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => [Text] -> m () layoutWriteAppendMultiline ts = do traceLocal ("layoutWriteAppendMultiline", ts) case ts of - [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. - (l : lr) -> do + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. + (l:lr) -> do layoutWriteAppend l lr `forM_` \x -> do layoutWriteNewline @@ -74,15 +91,16 @@ layoutWriteAppendMultiline ts = do -- adds a newline and adds spaces to reach the base column. layoutWriteNewlineBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteNewlineBlock = do traceLocal ("layoutWriteNewlineBlock") state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - } + mSet $ state { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + } -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- , MonadMultiWriter (Seq String) m) => Int -> m () @@ -98,13 +116,13 @@ layoutWriteNewlineBlock = do -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } -layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () +layoutSetCommentCol + :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol = do state <- mGet - let - col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + let col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state traceLocal ("layoutSetCommentCol", col) unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } @@ -112,7 +130,9 @@ layoutSetCommentCol = do -- This is also used to move to non-comments in a couple of places. Seems -- to be harmless so far.. layoutMoveToCommentPos - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> Int -> Int @@ -122,35 +142,38 @@ layoutMoveToCommentPos y x commentLines = do state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y + Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = + , _lstate_addSepSpace = Just $ if Data.Maybe.isJust (_lstate_commentCol state) then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_commentCol = + Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 + _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteNewline = do traceLocal ("layoutWriteNewline") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing + , _lstate_addSepSpace = Nothing } _layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () @@ -158,67 +181,77 @@ _layoutResetCommentNewlines = do mModify $ \state -> state { _lstate_commentNewlines = 0 } layoutWriteEnsureNewlineBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteEnsureNewlineBlock = do traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing } layoutWriteEnsureAbsoluteN - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let - diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c, _) -> n - c - (Nothing, Left i) -> n - i - (Nothing, Right{}) -> n + let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c , _ ) -> n - c + (Nothing, Left i ) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to + mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to -- at least (Just 1), so we won't -- overwrite any old value in any -- bad way. + } -layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m () +layoutBaseYPushInternal + :: (MonadMultiState LayoutState m) + => Int + -> m () layoutBaseYPushInternal i = do traceLocal ("layoutBaseYPushInternal", i) mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } -layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m () +layoutBaseYPopInternal + :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal = do traceLocal ("layoutBaseYPopInternal") mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m) => Int -> m () + :: (MonadMultiState LayoutState m) + => Int + -> m () layoutIndentLevelPushInternal i = do traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s - { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } -layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPopInternal + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal = do traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s - { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } -layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () +layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger = do - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + } layoutWithAddBaseCol :: ( MonadMultiWriter Text.Builder.Builder m @@ -250,7 +283,9 @@ layoutWithAddBaseColBlock m = do layoutBaseYPopInternal layoutWithAddBaseColNBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () -> m () @@ -263,23 +298,27 @@ layoutWithAddBaseColNBlock amount m = do layoutBaseYPopInternal layoutWriteEnsureBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteEnsureBlock = do traceLocal ("layoutWriteEnsureBlock") state <- mGet let diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i) -> lstate_baseY state - i + (Nothing, Left i ) -> lstate_baseY state - i (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i) -> max sp (lstate_baseY state - i) + (Just sp, Left i ) -> max sp (lstate_baseY state - i) (Just sp, Right{}) -> max sp (lstate_baseY state) -- when (diff>0) $ layoutWriteNewlineBlock when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just $ diff } layoutWithAddBaseColN - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () -> m () @@ -289,36 +328,39 @@ layoutWithAddBaseColN amount m = do m layoutBaseYPopInternal -layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () +layoutBaseYPushCur + :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur = do traceLocal ("layoutBaseYPushCur") state <- mGet case _lstate_commentCol state of Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> layoutBaseYPushInternal (i + j) - (Left i, Nothing) -> layoutBaseYPushInternal i - (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state + (Left i , Just j ) -> layoutBaseYPushInternal (i + j) + (Left i , Nothing) -> layoutBaseYPushInternal i + (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state Just cCol -> layoutBaseYPushInternal cCol -layoutBaseYPop :: (MonadMultiState LayoutState m) => m () +layoutBaseYPop + :: (MonadMultiState LayoutState m) => m () layoutBaseYPop = do traceLocal ("layoutBaseYPop") layoutBaseYPopInternal -layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPushCur + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur = do traceLocal ("layoutIndentLevelPushCur") state <- mGet - let - y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> i + j - (Left i, Nothing) -> i - (Right{}, Just j) -> j - (Right{}, Nothing) -> 0 + let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i , Just j ) -> i + j + (Left i , Nothing) -> i + (Right{}, Just j ) -> j + (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y -layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPop + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") layoutIndentLevelPopInternal @@ -328,12 +370,12 @@ layoutIndentLevelPop = do -- make sense. layoutRemoveIndentLevelLinger -layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () +layoutAddSepSpace :: (MonadMultiState LayoutState m) + => m () layoutAddSepSpace = do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state - } + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. @@ -348,7 +390,7 @@ moveToExactAnn annKey = do traceLocal ("moveToExactAnn", annKey) anns <- mAsk case Map.lookup annKey anns of - Nothing -> return () + Nothing -> return () Just ann -> do -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann @@ -357,19 +399,19 @@ moveToExactAnn annKey = do moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY y = mModify $ \state -> - let - upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in - state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just - (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } + let upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then + _lstate_commentCol state + <|> _lstate_addSepSpace state + <|> Just (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do @@ -379,7 +421,9 @@ moveToY y = mModify $ \state -> -- else x ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () + :: MonadMultiWriter Text.Builder.Builder m + => ExactPrint.DeltaPos + -> m () ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ y $ mTell $ Text.Builder.fromString " " @@ -395,77 +439,75 @@ layoutWritePriorComments layoutWritePriorComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - key - anns + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns } return mAnn case mAnn of Nothing -> return () Just priors -> do unless (null priors) $ layoutSetCommentCol - priors - `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment + priors `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. -- per documentation, this seems sufficient, as the -- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Located ast - -> m () +layoutWritePostComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Located ast -> m () layoutWritePostComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just posts -> do unless (null posts) $ layoutSetCommentCol - posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> - do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment + posts `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment - :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) + :: ( MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + ) => m () layoutIndentRestorePostComment = do state <- mGet let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state - mModify - $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } + let eCurYAddNL = _lstate_curYOrAddNewline state + mModify $ \s -> s { _lstate_commentCol = Nothing + , _lstate_commentNewlines = 0 + } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe - 0 - (_lstate_addSepSpace state) - _ -> return () + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) + _ -> return () -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs index b951db9..66d6d7f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -3,174 +3,185 @@ module Language.Haskell.Brittany.Internal.Config where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Bool as Bool import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Coerce (coerce) -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Semigroup as Semigroup -import qualified Data.Yaml import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances () -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Utils -import qualified System.Console.CmdArgs.Explicit as CmdArgs import qualified System.Directory -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath import qualified System.IO -import UI.Butcher.Monadic +import qualified Data.Yaml +import Data.CZipWith + +import UI.Butcher.Monadic + +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 ( coerce + ) +import qualified Data.List.NonEmpty as NonEmpty + +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] } --- brittany-next-binding --columns 200 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") - dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") - dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") - dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") - dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") - dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") - dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = mempty } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Bool.bool Nothing (Just True) @@ -217,8 +228,8 @@ readConfig path = do fileConf <- case Data.Yaml.decodeEither' contents of Left e -> do liftIO - $ putStrErrLn - $ "error reading in brittany config from " + $ putStrErrLn + $ "error reading in brittany config from " ++ path ++ ":" liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) @@ -232,12 +243,11 @@ readConfig path = do userConfigPath :: IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith - Directory.doesFileExist - searchDirs - "config.yaml" + globalConfig <- Directory.findFileWith Directory.doesFileExist + searchDirs + "config.yaml" maybe (writeUserConfig userBritPathXdg) pure globalConfig where writeUserConfig dir = do @@ -249,7 +259,7 @@ userConfigPath = do -- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir + let dirParts = FilePath.splitDirectories dir -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" @@ -261,9 +271,8 @@ readConfigs -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let - merged = - Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + let merged = Semigroup.sconcat + $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 0b81ae6..929ac90 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -7,54 +7,63 @@ module Language.Haskell.Brittany.Internal.Config.Types where -import Data.CZipWith -import Data.Coerce (Coercible, coerce) -import Data.Data (Data) -import qualified Data.Semigroup as Semigroup -import Data.Semigroup (Last) -import Data.Semigroup.Generic -import GHC.Generics + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils () +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import Data.Data ( Data ) + +import Data.Coerce ( Coercible, coerce ) + +import Data.Semigroup.Generic +import Data.Semigroup ( Last ) + +import Data.CZipWith + + confUnpack :: Coercible a b => Identity a -> b confUnpack (Identity x) = coerce x data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. , _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentAmount :: f (Last Int) , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) + , _lconfig_importColumn :: f (Last Int) -- ^ for import statement layouting, column at which to align the -- elements to be imported from a module. -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) + , _lconfig_importAsColumn :: f (Last Int) -- ^ for import statement layouting, column at which put the module's -- "as" name (which also affects the positioning of the "as" keyword). -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) + , _lconfig_alignmentLimit :: f (Last Int) -- roughly speaking, this sets an upper bound to the number of spaces -- inserted to create horizontal alignment. -- More specifically, if 'xs' are the widths of the columns in some @@ -139,17 +148,17 @@ data CLayoutConfig f = LayoutConfig -- -- > , y :: Double -- -- > } } - deriving Generic + deriving (Generic) data CForwardOptions f = ForwardOptions { _options_ghc :: f [String] } - deriving Generic + deriving (Generic) data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) -- ^ Determines when to fall back on the exactprint'ed output when -- syntactical constructs are encountered which are not yet handled by -- brittany. @@ -159,21 +168,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig -- has different semantics than the code pre-transformation. , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CPreProcessorConfig f = PreProcessorConfig { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config @@ -184,9 +193,10 @@ data CConfig f = Config -- module. Useful for wildcard application -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) + , _conf_obfuscate :: f (Semigroup.Last Bool) + } - deriving Generic + deriving (Generic) type DebugConfig = CDebugConfig Identity type LayoutConfig = CLayoutConfig Identity diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index be7a0bb..2c0c78f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -18,16 +18,22 @@ module Language.Haskell.Brittany.Internal.Config.Types.Instances where + + +import Language.Haskell.Brittany.Internal.Prelude + +import Data.Yaml import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson -import Data.Yaml + import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude + + aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany = Aeson.defaultOptions { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (== '_') + , Aeson.fieldLabelModifier = dropWhile (=='_') } instance FromJSON (CDebugConfig Maybe) where @@ -102,18 +108,17 @@ instance ToJSON (CConfig Maybe) where -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- config file content. instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = - Config - <$> (v .:? Key.fromString "conf_version") - <*> (v .:?= Key.fromString "conf_debug") - <*> (v .:?= Key.fromString "conf_layout") - <*> (v .:?= Key.fromString "conf_errorHandling") - <*> (v .:?= Key.fromString "conf_forward") - <*> (v .:?= Key.fromString "conf_preprocessor") - <*> (v .:? Key.fromString "conf_roundtrip_exactprint_only") - <*> (v .:? Key.fromString "conf_disable_formatting") - <*> (v .:? Key.fromString "conf_obfuscate") - parseJSON invalid = Aeson.typeMismatch "Config" invalid + parseJSON (Object v) = Config + <$> v .:? Key.fromString "conf_version" + <*> v .:?= Key.fromString "conf_debug" + <*> v .:?= Key.fromString "conf_layout" + <*> v .:?= Key.fromString "conf_errorHandling" + <*> v .:?= Key.fromString "conf_forward" + <*> v .:?= Key.fromString "conf_preprocessor" + <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" + <*> v .:? Key.fromString "conf_disable_formatting" + <*> v .:? Key.fromString "conf_obfuscate" + parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 5020745..46e1b6a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -7,35 +7,48 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils where -import Control.Exception + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.Data import qualified Data.Foldable as Foldable -import qualified Data.Generics as SYB -import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Set as Set -import GHC (GenLocated(L)) -import qualified GHC hiding (parseModule) -import GHC.Data.Bag -import qualified GHC.Driver.CmdLine as GHC -import qualified GHC.Driver.Session as GHC -import GHC.Hs -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.SrcLoc (Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified System.IO +import Language.Haskell.Brittany.Internal.Config.Types +import Data.Data +import Data.HList.HList + +import GHC ( GenLocated(L) ) +import qualified GHC.Driver.Session as GHC +import qualified GHC hiding (parseModule) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Driver.CmdLine as GHC + +import GHC.Hs +import GHC.Data.Bag + +import GHC.Types.SrcLoc ( SrcSpan, Located ) + + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint + +import qualified Data.Generics as SYB + +import Control.Exception +-- import Data.Generics.Schemes + + + parseModule :: [String] -> System.IO.FilePath @@ -54,7 +67,7 @@ parseModuleWithCpp -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleWithCpp cpp opts args fp dynCheck = ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ GHC.getSessionDynFlags + dflags0 <- lift $ GHC.getSessionDynFlags (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> ("-hide-all-packages" : args)) @@ -66,20 +79,17 @@ parseModuleWithCpp cpp opts args fp dynCheck = void $ lift $ GHC.setSessionDynFlags dflags1 dflags2 <- lift $ ExactPrint.initDynFlags fp unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " + $ ExceptT.throwE + $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " + $ ExceptT.throwE + $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) - x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 + x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp - either - (\err -> ExceptT.throwE $ "transform error: " ++ show - (bagToList (show <$> err)) - ) - (\(a, m) -> pure (a, m, x)) + either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) + (\(a, m) -> pure (a, m, x)) $ ExactPrint.postParseTransform res opts parseModuleFromString @@ -97,51 +107,46 @@ parseModuleFromString args fp dynCheck str = -- bridoc transformation stuff. -- (reminder to update note on `parsePrintModule` if this changes.) mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str + dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " + $ ExceptT.throwE + $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " + $ ExceptT.throwE + $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of - Left err -> - ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) - Right (a, m) -> pure (a, m, dynCheckRes) + Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) + Right (a , m ) -> pure (a, m, dynCheckRes) commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob ast = do - let - extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` (\l@(L span _) -> - Seq.singleton (span, ExactPrint.mkAnnKey l) - ) + let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` + (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) let nodes = SYB.everything (<>) extract ast - let - annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] + let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (const id) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes + ] nodes `forM_` (snd .> processComs annsMap) where processComs annsMap annKey1 = do mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn `forM_` \ann1 -> do - let - priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 + let priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 let processCom :: (ExactPrint.Comment, ExactPrint.DeltaPos) @@ -153,32 +158,31 @@ commentAnnFixTransformGlob ast = do (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> move $> False (x, y) | x == y -> move $> False - _ -> return True + _ -> return True where ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 move = ExactPrint.modifyAnnsT $ \anns -> let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2' = ann2 { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] + ExactPrint.annFollowingComments ann2 ++ [comPair] } - in Map.insert annKey2 ann2' anns + in + Map.insert annKey2 ann2' anns _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors + priors' <- filterM processCom priors follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case + assocs' <- flip filterM assocs $ \case (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let - ann1' = ann1 - { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } + _ -> return True + let ann1' = ann1 { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns @@ -266,30 +270,29 @@ extractToplevelAnns lmod anns = output | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns ] declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + 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 +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 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 + ( \x -> maybe Set.empty Set.singleton [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x - ] -- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- even though it is passed to mkAnnKey above, which only accepts -- SrcSpan. + ] ) ast where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) @@ -298,8 +301,8 @@ foldedAnnKeys ast = SYB.everything withTransformedAnns :: Data ast => ast - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case readers@(conf :+: anns :+: HNil) -> do -- TODO: implement `local` for MultiReader/MultiRWS @@ -309,10 +312,9 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case pure x where f anns = - let - ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced + let ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced warnExtractorCompat :: GHC.Warn -> String diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 8f861d4..422c7be 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -6,37 +6,50 @@ module Language.Haskell.Brittany.Internal.LayouterBasics where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Writer.Strict as Writer -import qualified Data.Char as Char -import Data.Data import qualified Data.Map as Map import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import DataTreePrint -import GHC (GenLocated(L), Located, moduleName, moduleNameString) import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.Name (getOccString) -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader (RdrName(..)) -import qualified GHC.Types.SrcLoc as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import qualified Control.Monad.Writer.Strict as Writer + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import GHC.Types.Name.Reader ( RdrName(..) ) +import GHC ( Located, GenLocated(L), moduleName, moduleNameString ) +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name ( getOccString ) +import GHC.Parser.Annotation ( AnnKeywordId(..) ) + +import Data.Data + +import qualified Data.Char as Char + +import DataTreePrint + + + processDefault :: ( ExactPrint.Annotate.Annotate ast , MonadMultiWriter Text.Builder.Builder m @@ -54,7 +67,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString str + _ -> mTell $ Text.Builder.fromString str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -66,10 +79,9 @@ briDocByExact -> ToBriDocM BriDocNumbered briDocByExact ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns True -- | Use ExactPrint's output for this node. @@ -83,10 +95,9 @@ briDocByExactNoComment -> ToBriDocM BriDocNumbered briDocByExactNoComment ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns False -- | Use ExactPrint's output for this node, presuming that this output does @@ -99,26 +110,24 @@ briDocByExactInlineOnly -> ToBriDocM BriDocNumbered briDocByExactInlineOnly infoStr ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let - exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t - let - errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + let exactPrintNode t = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + t + let errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit + $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _) -> errorAction - (_, [t]) -> exactPrintNode + (ExactPrintFallbackModeNever, _ ) -> errorAction + (_ , [t]) -> exactPrintNode (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted _ -> errorAction @@ -143,21 +152,20 @@ lrdrNameToTextAnnGen lrdrNameToTextAnnGen f ast@(L _ n) = do anns <- mAsk let t = f $ rdrNameToText n - let - hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False + let hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. -- whatever we don't probably should have had some effect on the -- output. in such cases, resorting to byExact is probably the safe -- choice. return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t + Nothing -> t Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t lrdrNameToTextAnn :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) @@ -170,10 +178,9 @@ lrdrNameToTextAnnTypeEqualityIsSpecial => Located RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let - f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + let f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x lrdrNameToTextAnnGen f ast -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects @@ -191,11 +198,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick -> m Text lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let - lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + x <- lrdrNameToTextAnn ast2 + let lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x return $ if hasQuote then Text.cons '\'' lit else lit askIndent :: (MonadMultiReader Config m) => m Int @@ -213,11 +219,12 @@ extractRestComments ann = ExactPrint.annFollowingComments ann ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] + _ -> [] ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +filterAnns ast = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) -- | True if there are any comments that are -- a) connected to any node below (in AST sense) the given node AND @@ -235,16 +242,15 @@ hasCommentsBetween -> ToBriDocM Bool hasCommentsBetween ast leftKey rightKey = do mAnn <- astAnn ast - let - go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest + let go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest case mAnn of - Nothing -> pure False + Nothing -> pure False Just ann -> pure $ go1 $ ExactPrint.annsDP ann -- | True if there are any comments that are connected to any node below (in AST @@ -254,8 +260,7 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast -- | True if there are any regular comments connected to any node below (in AST -- sense) the given node -hasAnyRegularCommentsConnected - :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyRegularCommentsConnected ast = any isRegularComment <$> astConnectedComments ast @@ -292,7 +297,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False + Nothing -> False Just ann -> any hasK (extractAllComments ann) where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst @@ -306,7 +311,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks where hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False + hasK _ = False astAnn :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) @@ -455,10 +460,12 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) deriving (Functor, Applicative, Monad) addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = when cond (addAlternative doc) +addAlternativeCond cond doc = + when cond (addAlternative doc) addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = CollectAltM . Writer.tell . (: []) +addAlternative = + CollectAltM . Writer.tell . (: []) runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative (CollectAltM action) = @@ -475,8 +482,7 @@ docLines l = allocateNode . BDFLines =<< sequence l docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docCols sig l = allocateNode . BDFCols sig =<< sequence l -docAddBaseY - :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -511,8 +517,7 @@ docAnnotationKW -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = - allocateNode . BDFAnnotationKW annKey kw =<< bdm +docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docMoveToKWDP :: AnnKey @@ -564,7 +569,7 @@ docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] docParenHashRSep :: ToBriDocM BriDocNumbered docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] @@ -626,26 +631,32 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNodePrior ast bdm = do bd <- bdm i1 <- allocNodeIndex - return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd + return + $ (,) i1 + $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ bd docWrapNodeRest ast bdm = do bd <- bdm i2 <- allocNodeIndex - return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd + return + $ (,) i2 + $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) + $ bd instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where docWrapNode ast bdms = case bdms of [] -> [] [bd] -> [docWrapNode ast bd] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdms = case bdms of [] -> [] [bd] -> [docWrapNodePrior ast bd] - (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR + (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + [] -> [] + (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do @@ -655,25 +666,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ [bd1'] ++ reverse bdM ++ [bdN'] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdsm = do bds <- bdsm case bds of [] -> return [] - (bd1 : bdR) -> do + (bd1:bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return (bd1' : bdR) + return (bd1':bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of [] -> return [] - (bdN : bdR) -> do + (bdN:bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN' : bdR) + return $ reverse (bdN':bdR) instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do @@ -686,7 +697,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where return $ Seq.singleton bd1' bdM Seq.:> bdN -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ (bd1' Seq.<| bdM) Seq.|> bdN' docWrapNodePrior ast bdsm = do bds <- bdsm @@ -730,7 +741,7 @@ docPar -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docPar lineM indentedM = do - line <- lineM + line <- lineM indented <- indentedM allocateNode $ BDFPar BrIndentNone line indented @@ -767,15 +778,14 @@ briDocMToPPM m = do briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR - let - ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m + let ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 3bafd56..acbe186 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -3,19 +3,26 @@ module Language.Haskell.Brittany.Internal.Layouters.DataDecl where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (GenLocated(L), Located) -import qualified GHC -import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( Located, GenLocated(L) ) +import qualified GHC +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Layouters.Type + + layoutDataDecl :: Located (TyClDecl GhcPs) @@ -25,29 +32,28 @@ layoutDataDecl -> ToBriDocM BriDocNumbered layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> - case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) - -> docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> + docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl -- data MyData a b @@ -55,8 +61,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "data" , lhsContextDoc @@ -68,36 +74,32 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- data MyData = MyData { .. } HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) - -> docWrapNode ltycl $ do + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> + docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing + Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- return <$> createDetailsDoc consNameStr details - consDoc <- - fmap pure + rhsDoc <- return <$> createDetailsDoc consNameStr details + consDoc <- fmap pure $ docNonBottomSpacing $ case (forallDocMay, rhsContextDocMay) of (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq - [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [ docLitS "." , docSeparator - , docSetBaseY - $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] ] (Just forallDoc, Nothing) -> docLines - [ docSeq - [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [docLitS ".", docSeparator, rhsDoc] ] (Nothing, Just rhsContextDoc) -> docSeq @@ -105,12 +107,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSeparator , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] - (Nothing, Nothing) -> - docSeq [docLitS "=", docSeparator, rhsDoc] + (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline $ lhsContextDoc , appSep $ docLit nameStr @@ -122,13 +124,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> - docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -136,26 +137,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr , tyVarLine ] ) - (docSeq + ( docSeq [ docLitS "=" , docSeparator , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> - docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -166,7 +167,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -187,10 +189,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- hurt. docAddBaseY BrIndentRegular $ docPar (docLitS "data") - (docLines + ( docLines [ lhsContextDoc , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq [appSep $ docLit nameStr, tyVarLine] + $ docSeq + [ appSep $ docLit nameStr + , tyVarLine + ] , consDoc ] ) @@ -204,20 +209,20 @@ createContextDoc [] = docEmpty createContextDoc [t] = docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 + t1Doc <- docSharedWrapper layoutType t1 tRDocs <- tR `forM` docSharedWrapper layoutType docAlt [ docSeq [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse - docCommaSep - (t1Doc : tRDocs) + , docForceSingleline $ docSeq $ List.intersperse docCommaSep + (t1Doc : tRDocs) , docLitS ") =>" , docSeparator ] , docLines $ join [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , tRDocs + <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] , [docLitS ") =>", docSeparator] ] ] @@ -229,18 +234,20 @@ createBndrDoc bs = do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) - docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> - case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -249,47 +256,48 @@ createDerivingPar derivs mainDoc = do (L _ []) -> mainDoc (L _ types) -> docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = - case types of - (L _ []) -> docSeq [] - (L _ ts) -> - let - tsLength = length ts - whenMoreThan1Type val = - if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = - maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in docSeq +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = + if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in + docSeq [ docDeriving , docWrapNodePrior types $ lhsStrategy , docSeparator , whenMoreThan1Type "(" , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts - <&> \case - HsIB _ t -> layoutType t + $ docSeq + $ List.intersperse docCommaSep + $ ts <&> \case + HsIB _ t -> layoutType t , whenMoreThan1Type ")" , rhsStrategy ] where strategyLeftRight = \case - (L _ StockStrategy) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes)) -> + (L _ StockStrategy ) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) + lVia@(L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of - HsIB _ext t -> docSeq - [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] + HsIB _ext t -> docSeq + [ docWrapNode lVia $ docLitS " via" + , docSeparator + , layoutType t + ] ) docDeriving :: ToBriDocM BriDocNumbered @@ -299,25 +307,21 @@ createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of PrefixCon args -> do - indentPolicy <- - mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq [ docLit consNameStr , docSeparator , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ fmap hsScaledThing args - <&> layoutType + $ docSeq + $ List.intersperse docSeparator + $ fmap hsScaledThing args <&> layoutType ] - leftIndented = - docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType - <$> fmap hsScaledThing args + leftIndented = docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType <$> fmap hsScaledThing args multiAppended = docSeq [ docLit consNameStr , docSeparator @@ -327,80 +331,79 @@ createDetailsDoc consNameStr details = case details of (docLit consNameStr) (docLines $ layoutType <$> fmap hsScaledThing args) case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyFree -> docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> - docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_ : _)) -> do + RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_:_)) -> do let ((fName1, fType1) : fDocR) = mkFieldDocs fields -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False - docAddBaseY BrIndentRegular $ runFilteredAlternative $ do + docAddBaseY BrIndentRegular + $ runFilteredAlternative + $ do -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" - ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols - ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 - , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 - ] - , docSeq - [ docLitS "{" - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) - ] - ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols - ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] + , docSeparator , docLitS "}" ] - ) + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName + , docSeq [docLitS "::", docSeparator] + , docForceSingleline fType + ] + , docSeq + [ docLitS "," + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName + (docSeq [docLitS "::", docSeparator, fType]) + ] + ] + , docLitS "}" + ] + ) InfixCon arg1 arg2 -> docSeq [ layoutType $ hsScaledThing arg1 , docSeparator @@ -415,11 +418,10 @@ createDetailsDoc consNameStr details = case details of mkFieldDocs = fmap $ \lField -> case lField of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t -createForallDoc - :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = - Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] +createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = Just $ docSeq + [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc :: Data.Data.Data ast @@ -429,8 +431,12 @@ createNamesAndTypeDoc -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq $ List.intersperse docCommaSep $ names <&> \case - L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \case + L _ (FieldOcc _ fieldName) -> + docLit =<< lrdrNameToTextAnn fieldName ] , docWrapNodeRest lField $ layoutType t ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index c2ff209..a96ae47 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -5,46 +5,56 @@ module Language.Haskell.Brittany.Internal.Layouters.Decl where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Foldable import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Data.Bag (bagToList, emptyBag) -import qualified GHC.Data.FastString as FastString -import GHC.Hs import qualified GHC.OldList as List -import GHC.Types.Basic - ( Activation(..) - , InlinePragma(..) - , InlineSpec(..) - , LexicalFixity(..) - , RuleMatchInfo(..) - ) -import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Layouters.Type + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import GHC ( GenLocated(L) + , AnnKeywordId(..) + ) +import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc ) +import qualified GHC.Data.FastString as FastString +import GHC.Hs +import GHC.Types.Basic ( InlinePragma(..) + , Activation(..) + , InlineSpec(..) + , RuleMatchInfo(..) + , LexicalFixity(..) + ) +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.DataDecl + +import GHC.Data.Bag ( bagToList, emptyBag ) + + layoutDecl :: ToBriDoc HsDecl layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> @@ -57,61 +67,52 @@ layoutDecl d@(L loc decl) = case decl of layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> - layoutNamesAndType Nothing names typ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig spec - let - phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let - conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " + let phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> - layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> - layoutNamesAndType (Just "pattern") names typ + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ + PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ _ -> briDocByExactNoComment lsig -- TODO where layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let - keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] + let keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- - mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack + shouldBeHanging <- mAsk + <&> _conf_layout + .> _lconfig_hangingTypeSignature + .> confUnpack if shouldBeHanging - then - docSeq - $ [ appSep - $ docWrapNodeRest lsig - $ docSeq - $ keyDoc - <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ] + then docSeq $ + [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc ] + ] + ] else layoutLhsAndType hasComments (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) @@ -121,23 +122,22 @@ layoutSig lsig@(L _loc sig) = case sig of specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body + BodyStmt _ body _ _ -> layoutExpr body BindStmt _ lPat expr -> do patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr - docCols - ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO + docCols ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- @@ -145,33 +145,37 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -------------------------------------------------------------------------------- layoutBind - :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) + :: ToBriDocC + (HsBindLR GhcPs GhcPs) + (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" funcPatDocs <- docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches return $ Left $ funcPatDocs PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat + patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" + binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal - Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereArg + hasComments PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID + lpat + dir + rpat _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of @@ -181,13 +185,7 @@ layoutIPBind lipbind@(L _ bind) = case bind of binderDoc <- docLit $ Text.pack "=" exprDoc <- layoutExpr expr hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal - Nothing - binderDoc - (Just ipName) - [([], exprDoc, expr)] - Nothing - hasComments + layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) @@ -195,7 +193,7 @@ data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) @@ -205,18 +203,18 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let - unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + let unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s + BagSig s -> return <$> layoutSig s return $ Just $ docs -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb + HsIPBinds _ (IPBinds _ bb) -> + Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is @@ -226,7 +224,7 @@ layoutGrhs -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body + bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) layoutPatternBind @@ -235,7 +233,7 @@ layoutPatternBind -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match + let pats = m_pats match let (GRHSs _ grhss whereBinds) = m_grhss match patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match @@ -244,26 +242,25 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1 : p2 : pr) | isInfix -> if null pr - then docCols - ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else docCols - ColPatternsFuncInfix - ([ docCols - ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR + (Just idStr, p1:p2:pr) | isInfix -> if null pr + then + docCols ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else + docCols ColPatternsFuncInfix + ( [docCols ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR + ] ] - ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix @@ -277,30 +274,30 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal - alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments + layoutPatternBindFinal alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereArg + hasComments -fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier + :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match where go = \case - (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr + (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1) -> goInner ctx1 - _ -> idStr + (StmtCtxt ctx1 ) -> goInner ctx1 + _ -> idStr -- I have really no idea if this path ever occurs, but better safe than -- risking another "drop bangpatterns" bugs. goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr + _ -> idStr layoutPatternBindFinal :: Maybe Text @@ -311,304 +308,304 @@ layoutPatternBindFinal -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments - = do - let - patPartInline = case mPatDoc of - Nothing -> [] +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do + let patPartInline = case mPatDoc of + Nothing -> [] Just patDoc -> [appSep $ docForceSingleline $ return patDoc] patPartParWrap = case mPatDoc of - Nothing -> id + Nothing -> id Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- - mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack - regularIndentAmount <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt - [ docEnsureIndent BrIndentRegular $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False + whereIndent <- do + shouldSpecial <- mAsk + <&> _conf_layout + .> _lconfig_indentWhereSpecial + .> confUnpack + regularIndentAmount <- mAsk + <&> _conf_layout + .> _lconfig_indentAmount + .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + [ docEnsureIndent BrIndentRegular + $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docMoveToKWDP annKeyWhere AnnWhere False $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let - singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty + ] + ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> - docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse - docCommaSep - (docForceSingleline . return <$> gs) + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + gs -> docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ (List.intersperse docCommaSep + (docForceSingleline . return <$> gs) ) wherePart = case mWhereDocs of - Nothing -> Just docEmpty + Nothing -> Just docEmpty Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] - _ -> Nothing + _ -> Nothing - indentPolicy <- - mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack - runFilteredAlternative $ do + runFilteredAlternative $ do - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' - ] + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine + ] + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ (case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline $ docSeq - [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - (case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline $ docSeq - [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - (case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1 : gr) -> - (docSeq [appSep $ docLit $ Text.pack "|", return g1] - : (gr - <&> \g -> docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc - ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) ] - ] - ++ wherePartMultiLine + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1:gr) -> + ( docSeq [appSep $ docLit $ Text.pack "|", return g1] + : ( gr + <&> \g -> + docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine -- | Layout a pattern synonym binding layoutPatSynBind @@ -618,51 +615,44 @@ layoutPatSynBind -> LPat GhcPs -> ToBriDocM BriDocNumbered layoutPatSynBind name patSynDetails patDir rpat = do - let - patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" + let patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir - headDoc <- - fmap pure - $ docSeq - $ [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] + headDoc <- fmap pure $ docSeq $ + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] runFilteredAlternative $ do - addAlternative - $ + addAlternative $ -- pattern .. where -- .. -- .. - docAddBaseY BrIndentRegular - $ docSeq - ([headDoc, docSeparator, body] ++ case mWhereDocs of + docAddBaseY BrIndentRegular $ docSeq + ( [headDoc, docSeparator, body] + ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] - ) - addAlternative - $ + ) + addAlternative $ -- pattern .. = -- .. -- pattern .. <- -- .. where -- .. -- .. - docAddBaseY BrIndentRegular - $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> - docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) - ) + docAddBaseY BrIndentRegular $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) + ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn @@ -681,21 +671,18 @@ layoutLPatSyn name (InfixCon left right) = do layoutLPatSyn name (RecCon recArgs) = do docName <- lrdrNameToTextAnn name args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq - . fmap docLit - $ [docName, Text.pack " { "] + docSeq . fmap docLit + $ [docName, Text.pack " { " ] <> intersperse (Text.pack ", ") args <> [Text.pack " }"] -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms -layoutPatSynWhere - :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG _ (L _ lbinds) _) -> do binderDoc <- docLit $ Text.pack "=" - Just - <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing -------------------------------------------------------------------------------- @@ -705,10 +692,9 @@ layoutPatSynWhere hs = case hs of layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl _ name vars fixity typ -> do - let - isInfix = case fixity of - Prefix -> False - Infix -> True + let isInfix = case fixity of + Prefix -> False + Infix -> True -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl @@ -737,7 +723,9 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do -- This isn't quite right, but does give syntactically valid results let needsParens = not (null rest) || hasOwnParens docSeq - $ [docLit $ Text.pack "type", docSeparator] + $ [ docLit $ Text.pack "type" + , docSeparator + ] ++ [ docParenL | needsParens ] ++ [ layoutTyVarBndr False a , docSeparator @@ -749,13 +737,13 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do ++ fmap (layoutTyVarBndr True) rest else docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc @@ -764,11 +752,11 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name - docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] + docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] KindedTyVar _ _ name kind -> do nameStr <- lrdrNameToTextAnn name docSeq - $ [ docSeparator | needsSep ] + $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" @@ -796,7 +784,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name + nameStr <- lrdrNameToTextAnn name needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass @@ -807,35 +795,33 @@ layoutTyFamInstDecl inClass outerNode tfid = do makeForallDoc bndrs = do bndrDocs <- layoutTyVarBndrs bndrs docSeq - ([docLit (Text.pack "forall")] + ( [docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs ) lhs = docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] + . docSeq + $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] - hasComments <- - (||) + hasComments <- (||) <$> hasAnyRegularCommentsConnected outerNode <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc -layoutHsTyPats - :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm + HsValArg tm -> layoutType tm HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change -- is a bit strange. Hopefully this does not ignore any important -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" + HsArgPar _l -> error "brittany internal error: HsArgPar{}" -------------------------------------------------------------------------------- -- ClsInstDecl @@ -850,27 +836,27 @@ layoutClsInst :: ToBriDoc ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) ] where layoutInstanceHead :: ToBriDocM BriDocNumbered layoutInstanceHead = briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren <$> lcid removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] , cid_datafam_insts = [] } @@ -878,11 +864,7 @@ layoutClsInst lcid@(L _ cid) = docLines docSortedLines :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = - allocateNode - . BDFLines - . fmap unLoc - . List.sortOn (ExactPrint.rs . getLoc) - =<< sequence l + allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig @@ -894,8 +876,8 @@ layoutClsInst lcid@(L _ cid) = docLines joinBinds :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n + Left ns -> docLines $ return <$> ns + Right n -> return n layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) @@ -961,11 +943,10 @@ layoutClsInst lcid@(L _ cid) = docLines stripWhitespace' t = Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t where - go [] = [] + go [] = [] go (line1 : lineR) = case Text.stripStart line1 of - st - | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR + st | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "newtype" `Text.isPrefixOf` t') @@ -988,12 +969,7 @@ layoutLhsAndType hasComments lhs sep typeDoc = do -- lhs = type -- lhs :: type addAlternativeCond (not hasComments) $ docSeq - [ lhs - , docSeparator - , docLitS sep - , docSeparator - , docForceSingleline typeDoc - ] + [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3bc4c67..344454c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -4,150 +4,149 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) -import qualified GHC.Data.FastString as FastString -import GHC.Hs import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Types.Name -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( GenLocated(L), SrcSpan, AnnKeywordId(..), RdrName(..) ) +import GHC.Hs +import GHC.Types.Name +import qualified GHC.Data.FastString as FastString +import GHC.Types.Basic + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type + + layoutExpr :: ToBriDoc HsExpr layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of HsVar _ vname -> do docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname + HsUnboundVar _ oname -> + docLit $ Text.pack $ occNameString oname HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label + let label = FastString.unpackFS name + in docLit . Text.pack $ '#' : label HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label + let label = FastString.unpackFS name + in docLit . Text.pack $ '?' : label HsOverLit _ olit -> do allocateNode $ overLitValBriDoc $ ol_val olit HsLit _ lit -> do allocateNode $ litBriDoc lit HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds{} <- llocals - , L _ (GRHS _ [] body) <- lgrhs + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds {} <- llocals + , L _ (GRHS _ [] body) <- lgrhs -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let - shouldPrefixSeparator = case p of + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let shouldPrefixSeparator = case p of L _ LazyPat{} -> isFirst L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- - docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let - funcPatternPartLine = docCols - ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let funcPatternPartLine = + docCols ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc ] - HsLam{} -> unknownNodeError "HsLam too complex" lexpr - HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular - $ (docLit $ Text.pack "\\case {}") + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing + $ docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> + unknownNodeError "HsLam too complex" lexpr + HsLamCase _ (MG _ (L _ []) _) -> do + docSetParSpacing $ docAddBaseY BrIndentRegular $ + (docLit $ Text.pack "\\case {}") HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let - gather - :: [LHsExpr GhcPs] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r : list) l - x -> (x, list) + let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) + gather list = \case + L _ (HsApp _ l r) -> gather (r:list) l + x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 - let - colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq + let colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs hasComments <- hasAnyCommentsConnected exp2 @@ -159,13 +158,13 @@ layoutExpr lexpr@(L _ expr) = do : spacifyDocs (docForceSingleline <$> paramDocs) -- foo x -- y - addAlternativeCond allowFreeIndent $ docSeq + addAlternativeCond allowFreeIndent + $ docSeq [ appSep (docForceSingleline headDoc) , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ docForceSingleline - <$> paramDocs + $ docForceSingleline <$> paramDocs ] -- foo -- x @@ -174,25 +173,30 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docForceSingleline headDoc) - (docNonBottomSpacing $ docLines paramDocs) + (docForceSingleline headDoc) + ( docNonBottomSpacing + $ docLines paramDocs + ) -- ( multi -- line -- function -- ) -- x -- y - addAlternative $ docAddBaseY BrIndentRegular $ docPar - headDoc - (docNonBottomSpacing $ docLines paramDocs) + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + headDoc + ( docNonBottomSpacing + $ docLines paramDocs + ) HsApp _ exp1 exp2 -> do -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 docAlt [ -- func arg - docSeq - [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] , -- func argline1 -- arglines -- e.g. @@ -205,70 +209,77 @@ layoutExpr lexpr@(L _ expr) = do -- anyways, so it is _always_ par-spaced. $ docAddBaseY BrIndentRegular $ docSeq - [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] + [ appSep $ docForceSingleline expDoc1 + , docForceParSpacing expDoc2 + ] , -- func -- arg - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar (docForceSingleline expDoc1) (docNonBottomSpacing expDoc2) , -- fu -- nc -- ar -- gument - docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 + docAddBaseY BrIndentRegular + $ docPar + expDoc1 + expDoc2 ] HsAppType _ exp1 (HsWC _ ty1) -> do t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 docAlt [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar e (docSeq [docLit $ Text.pack "@", t]) + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar + e + (docSeq [docLit $ Text.pack "@", t ]) ] OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let - gather - :: [(LHsExpr GhcPs, LHsExpr GhcPs)] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft + let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) + gather opExprList = \case + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x, y) -> - [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight + appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight allowSinglelinePar <- do hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp + hasComOp <- hasAnyCommentsConnected expOp pure $ not hasComLeft && not hasComOp - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True runFilteredAlternative $ do -- > one + two + three -- or -- > one + two + case x of -- > _ -> three - addAlternativeCond allowSinglelinePar $ docSeq + addAlternativeCond allowSinglelinePar + $ docSeq [ appSep $ docForceSingleline leftOperandDoc - , docSeq $ appListDocs <&> \(od, ed) -> docSeq - [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] + , docSeq + $ appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] , appSep $ docForceSingleline opLastDoc , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc + expLastDoc ] -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) @@ -283,31 +294,29 @@ layoutExpr lexpr@(L _ expr) = do -- > one -- > + two -- > + three - addAlternative $ docPar - leftOperandDoc - (docLines - $ (appListDocs <&> \(od, ed) -> - docCols ColOpPrefix [appSep od, docSetBaseY ed] + addAlternative $ + docPar + leftOperandDoc + ( docLines + $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - ) OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let - leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line - addAlternative $ docSeq + addAlternative + $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceSingleline expDocRight @@ -322,35 +331,35 @@ layoutExpr lexpr@(L _ expr) = do -- two-line addAlternative $ do let - expDocOpAndRight = docForceSingleline $ docCols - ColOpPrefix - [appSep $ expDocOp, docSetBaseY expDocRight] + expDocOpAndRight = docForceSingleline + $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight + else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight -- TODO: in both cases, we don't force expDocLeft to be -- single-line, which has certain.. interesting consequences. -- At least, the "two-line" label is not entirely -- accurate. -- one-line + par - addAlternativeCond allowPar $ docSeq + addAlternativeCond allowPar + $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceParSpacing expDocRight ] -- more lines addAlternative $ do - let - expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + let expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight + $ docPar expDocLeft expDocOpAndRight NegApp _ op _ -> do opDoc <- docSharedWrapper layoutExpr op - docSeq [docLit $ Text.pack "-", opDoc] + docSeq [ docLit $ Text.pack "-" + , opDoc + ] HsPar _ innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -360,8 +369,7 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack ")" ] , docSetBaseY $ docLines - [ docCols - ColOpPrefix + [ docCols ColOpPrefix [ docLit $ Text.pack "(" , docAddBaseY (BrIndentSpecial 2) innerExpDoc ] @@ -370,33 +378,33 @@ layoutExpr lexpr@(L _ expr) = do ] SectionL _ left op -> do -- TODO: add to testsuite leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple _ args boxity -> do - let - argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e) - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> - docWrapNode arg $ maybe docEmpty layoutExpr exprM + let argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e); + (L _ (Missing NoExtField)) -> (arg, Nothing) + argDocs <- forM argExprs + $ docSharedWrapper + $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM hasComments <- orM - (hasCommentsBetween lexpr AnnOpenP AnnCloseP + ( hasCommentsBetween lexpr AnnOpenP AnnCloseP : map hasAnyCommentsBelow args ) - let - (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) + let (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) case splitFirstLast argDocs of - FirstLastEmpty -> - docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] + FirstLastEmpty -> docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) closeLit + ] FirstLastSingleton e -> docAlt - [ docCols - ColTuple + [ docCols ColTuple [ openLit , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e , closeLit @@ -411,88 +419,74 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [ docSeq - [ docCommaSep - , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) - , closeLit - ] - ] - addAlternative - $ let - start = docCols ColTuples [appSep openLit, e1] - linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] - lineN = docCols - ColTuples - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + addAlternative $ + let + start = docCols ColTuples + [appSep openLit, e1] + linesM = ems <&> \d -> + docCols ColTuples [docCommaSep, d] + lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase _ cExp (MG _ (L _ []) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp docAlt - [ docAddBaseY BrIndentRegular $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] + [ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") ] HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docAlt - [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq + [ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq [ appSep $ docLit $ Text.pack "case" , appSep $ docForceSingleline cExpDoc , docLit $ Text.pack "of" - ] - ) - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) + ]) + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "of") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "of") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) - ) ] HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr + ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr hasComments <- hasAnyCommentsBelow lexpr - let - maySpecialIndent = case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 + let maySpecialIndent = + case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. docSetIndentLevel $ runFilteredAlternative $ do -- if _ then _ else _ - addAlternativeCond (not hasComments) $ docSeq + addAlternativeCond (not hasComments) + $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc , appSep $ docLit $ Text.pack "then" @@ -517,34 +511,25 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq + ( docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) - $ docForceSingleline ifExprDoc - ] - ) + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ]) (docLines [ docAddBaseY BrIndentRegular $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] + $ docNonBottomSpacing $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc + $ docPar (docLit $ Text.pack "then") thenExprDoc ] - ] - ) + , docAddBaseY BrIndentRegular + $ docNonBottomSpacing $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) -- either -- if multi -- line @@ -562,69 +547,62 @@ layoutExpr lexpr@(L _ expr) = do -- else -- stuff -- note that this does _not_ have par-spacing - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - ) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + addAlternative + $ docSetBaseY + $ docLines + [ docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc ] - ] - ) - addAlternative $ docSetBaseY $ docLines - [ docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "else") elseExprDoc - ] + ] HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" hasComments <- hasAnyCommentsBelow lexpr docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") - (layoutPatternBindFinal - Nothing - binderDoc - Nothing - clauseDocs - Nothing - hasComments - ) + (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x + ifIndentFreeElse x y = + case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), -- but is here due to ghc-exactprint's DP handling of "let" in @@ -637,35 +615,36 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline - bindDoc + , docNodeAnnKW lexpr (Just AnnLet) + $ appSep $ docForceSingleline bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ] addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc + [ docNodeAnnKW lexpr (Just AnnLet) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) - ] , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse - docSetBaseAndIndent - docForceSingleline - expDoc1 + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY expDoc1) ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) - ] ] - Just bindDocs@(_ : _) -> runFilteredAlternative $ do + Just bindDocs@(_:_) -> runFilteredAlternative $ do --either -- let -- a = b @@ -679,91 +658,102 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - let - noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 + let noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular + $ docForceParSpacing expDoc1 + ] ] - ] addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq + IndentPolicyFree -> docLines + [ docNodeAnnKW lexpr (Just AnnLet) + $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines bindDocs ] - , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY expDoc1 + ] ] - addAlternative $ docLines + addAlternative + $ docLines [ docNodeAnnKW lexpr (Just AnnLet) $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of DoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) MDoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x - | case x of - ListComp -> True - MonadComp -> True - _ -> False - -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq - $ List.intersperse docCommaSep - $ docForceSingleline - <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative - $ let - start = docCols - ColListComp - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack - "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1 : sM) = List.init stmtDocs - line1 = - docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ docNodeAnnKW lexpr Nothing + $ appSep + $ docLit + $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq $ List.intersperse docCommaSep + $ docForceSingleline <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative $ + let + start = docCols ColListComp + [ docNodeAnnKW lexpr Nothing + $ appSep $ docLit $ Text.pack "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1:sM) = List.init stmtDocs + line1 = docCols ColListComp + [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] _ -> do -- TODO unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_ : _) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr + ExplicitList _ _ elems@(_:_) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of FirstLastEmpty -> docSeq @@ -787,106 +777,109 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse - docCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) - ) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) ++ [docLit $ Text.pack "]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> docCols ColList [docCommaSep, d] - lineN = docCols - ColList - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> docLit $ Text.pack "[]" - RecordCon _ lname fields -> case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- - fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- - fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> + docCols ColList [docCommaSep, d] + lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ExplicitList _ _ [] -> + docLit $ Text.pack "[]" + RecordCon _ lname fields -> + case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- fs + `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression False indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just (L _ 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr + recordExpression True indentPolicy lexpr nameDoc fieldDocs + _ -> unknownNodeError "RecordCon with puns" lexpr RecordUpd _ rExpr fields -> do rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- - fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFs <- fields + `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do rFExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ case ambName of Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) recordExpression False indentPolicy lexpr rExprDoc rFs ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 - docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] - ArithSeq _ Nothing info -> case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr + docSeq + [ appSep expDoc + , appSep $ docLit $ Text.pack "::" + , typDoc + ] + ArithSeq _ Nothing info -> + case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> + briDocByExactInlineOnly "ArithSeq" lexpr HsBracket{} -> do -- TODO briDocByExactInlineOnly "HsBracket{}" lexpr @@ -899,12 +892,11 @@ layoutExpr lexpr@(L _ expr) = do HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do allocateNode $ BDFPlain (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]" - ) + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]") HsSpliceE{} -> do -- TODO briDocByExactInlineOnly "HsSpliceE{}" lexpr @@ -936,79 +928,78 @@ recordExpression -> IndentPolicy -> GenLocated SrcSpan lExpr -> ToBriDocM BriDocNumbered - -> [ ( GenLocated SrcSpan name - , Text - , Maybe (ToBriDocM BriDocNumbered) - ) - ] + -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used +recordExpression False _ lexpr nameDoc [] = + docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression True _ lexpr nameDoc [] = + docSeq -- this case might still be incomplete, and is probably not used -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do let (rF1f, rF1n, rF1e) = rF1 runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } - addAlternative $ docSeq + addAlternative + $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr + , docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr , if dotdot - then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator + then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator , docLit $ Text.pack "}" ] -- hanging single-line fields -- container { fieldA = blub -- , fieldB = blub -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docSeq [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY - $ docLines - $ let - line1 = docCols - ColRec + , docSetBaseY $ docLines $ let + line1 = docCols ColRec [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit rF1n , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [appSep $ docLit $ Text.pack "=", docForceSingleline x] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq - [appSep $ docLit $ Text.pack "=", docForceSingleline x] + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] Nothing -> docEmpty - ] + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] + in [line1] ++ lineR ++ [dotdotLine, lineN] ] -- non-hanging with expressions placed to the right of the names -- container @@ -1016,75 +1007,77 @@ recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do -- , fieldB = potentially -- multiline -- } - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing - $ docLines - $ let - line1 = docCols - ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing $ docLines $ let + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRec [ docCommaSep , appSep $ docLit fText , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq [ appSep $ docLit $ Text.pack "=" + , docForceParSpacing x + ] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty ] - dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) + dotdotLine = if dotdot + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ) litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t _ -> error "litBriDoc: literal with no SourceText" overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 27256ef..8fb094b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -2,11 +2,20 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types + + +import Language.Haskell.Brittany.Internal.Prelude + +import Language.Haskell.Brittany.Internal.Types + +import GHC.Hs + + layoutExpr :: ToBriDoc HsExpr +-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) + litBriDoc :: HsLit GhcPs -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index dc1fafe..39b7a49 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -4,22 +4,26 @@ module Language.Haskell.Brittany.Internal.Layouters.IE where +import Language.Haskell.Brittany.Internal.Prelude import qualified Data.List.Extra import qualified Data.Text as Text -import GHC - ( AnnKeywordId(..) - , GenLocated(L) - , Located - , ModuleName - , moduleNameString - , unLoc - ) -import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + , ModuleName + ) +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Utils + + prepareName :: LIEWrappedName name -> Located name prepareName = ieLWrappedName @@ -33,41 +37,36 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] IEThingWith _ x _ ns _ -> do hasComments <- orM - (hasCommentsBetween lie AnnOpenP AnnCloseP + ( hasCommentsBetween lie AnnOpenP AnnCloseP : hasAnyCommentsBelow x : map hasAnyCommentsBelow ns ) let sortedNs = List.sortOn wrappedNameToText ns runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] + $ docSeq + $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc sortedNs) ++ [docParenR] addAlternative $ docWrapNodeRest lie $ docAddBaseY BrIndentRegular - $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) + $ docPar + (layoutWrapped lie x) + (layoutItems (splitFirstLast sortedNs)) where nameDoc = docLit <=< lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] - , docParenR - ] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] - , docParenR - ] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] layoutItems (FirstLast n1 nMs nN) = docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs - ++ [ docSeq - [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] - , docParenR - ] + ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] IEModuleContents _ n -> docSeq [ docLit $ Text.pack "module" , docSeparator @@ -76,7 +75,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEPattern n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "pattern " <> name @@ -93,36 +92,33 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: SortItemsFlag - -> Located [LIE GhcPs] - -> ToBriDocM [ToBriDocM BriDocNumbered] + :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] - let - sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let - ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies + let sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText + $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] + FirstLastEmpty -> [] FirstLastSingleton ie -> [ie] FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] pure $ fmap pure ieCommaDocs -- returned shared nodes where mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] + mergeGroup [] = [] mergeGroup items@[_] = items - mergeGroup items = if + mergeGroup items = if | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items -- proper means that if it is a ThingWith, it does not contain a wildcard -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). @@ -135,22 +131,21 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True - _ -> False + _ -> False thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{}) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 (L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder l1@(L _ IEVar{} ) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 ( L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l - (IEThingWith - x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) + (IEThingWith x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) ) thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -169,10 +164,9 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs - :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies + ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies runFilteredAlternative $ case ieDs of [] -> do @@ -182,14 +176,14 @@ layoutLLIEs enableSingleline shouldSort llies = do docParenR (ieDsH : ieDsT) -> do addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] + $ docSeq + $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) ++ [docParenR] addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT ++ [docParenR] -- | Returns a "fingerprint string", not a full text representation, nor even @@ -197,27 +191,26 @@ layoutLLIEs enableSingleline shouldSort llies = do -- Used for sorting, not for printing the formatter's output source code. wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n + L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. lieToText :: LIE GhcPs -> Text lieToText = \case - L _ (IEVar _ wn) -> wrappedNameToText wn - L _ (IEThingAbs _ wn) -> wrappedNameToText wn - L _ (IEThingAll _ wn) -> wrappedNameToText wn + L _ (IEVar _ wn ) -> wrappedNameToText wn + L _ (IEThingAbs _ wn ) -> wrappedNameToText wn + L _ (IEThingAll _ wn ) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn -- TODO: These _may_ appear in exports! -- Need to check, and either put them at the top (for module) or do some -- other clever thing. L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" where moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = - Text.pack ("@IEModuleContents" ++ moduleNameString name) + moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index df9d00f..1b19145 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -2,18 +2,26 @@ module Language.Haskell.Brittany.Internal.Layouters.Import where -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L), Located, moduleNameString, unLoc) -import GHC.Hs -import GHC.Types.Basic -import GHC.Unit.Types (IsBootInterface(..)) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , Located + ) +import GHC.Hs +import GHC.Types.Basic +import GHC.Unit.Types (IsBootInterface(..)) + + prepPkg :: SourceText -> String prepPkg rawN = case rawN of @@ -28,132 +36,111 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered layoutImport importD = case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- - mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- - mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let - compact = indentPolicy /= IndentPolicyFree + compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = - let - qualifiedPart = if q /= NotQualified then length "qualified " else 0 - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = case src of - IsBoot -> length "{-# SOURCE #-} " - NotBoot -> 0 - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal + let qualifiedPart = if q /= NotQualified then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength + asCost = length "as " + hidingParenCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" - , case src of - IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}" - NotBoot -> docEmpty + , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty - , if q /= NotQualified - then appSep $ docLit $ Text.pack "qualified" - else docEmpty + , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty , maybe docEmpty (appSep . docLit) pkgNameT ] indentName = if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = indentName $ appSep $ docLit modNameT - hidDocCol = - if hiding then importCol - hidingParenCost else importCol - 2 + modNameD = + indentName $ appSep $ docLit modNameT + hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = - if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + hidDoc = if hiding + then appSep $ docLit $ Text.pack "hiding" + else docEmpty importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of + bindingsD = case mllies of Nothing -> docEmpty Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docAlt - [ docSeq - [ hidDoc - , docForceSingleline $ layoutLLIEs True ShouldSortItems llies - ] - , let - makeParIfHiding = if hiding + then docAlt + [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] + , let makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq - [hidDoc, docParenLSep, docWrapNode llies docEmpty] - ) - (docEnsureIndent - (BrIndentSpecial hidDocColDiff) - docParenR - ) - else docSeq - [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD] - ) - (docEnsureIndent - (BrIndentSpecial hidDocColDiff) - docParenR - ) - -- ..[hiding].( b - -- , b' - -- ) - (ieD : ieDs') -> docPar - (docSeq - [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] - ) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + ] + else do + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + ( docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in - docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular - $ docPar (docSeq [importHead, asDoc]) bindingsD - ] - else case masT of + then + let asDoc = maybe docEmpty makeAsDoc masT + in docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular $ + docPar (docSeq [importHead, asDoc]) bindingsD + ] + else + case masT of Just n -> if enoughRoom - then docLines [docSeq [importHead, asDoc], bindingsD] + then docLines + [ docSeq [importHead, asDoc], bindingsD] else docLines [importHead, asDoc, bindingsD] where enoughRoom = nameCost < importAsCol - asCost - asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n + asDoc = + docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) + $ makeAsDoc n Nothing -> if enoughRoom then docSeq [importHead, bindingsD] else docLines [importHead, bindingsD] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index efae541..52c2cd1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -3,27 +3,34 @@ module Language.Haskell.Brittany.Internal.Layouters.Module where +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) -import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types - (DeltaPos(..), commentContents, deltaRow) + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import GHC.Hs +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types + ( DeltaPos(..) + , deltaRow + , commentContents + ) + + layoutModule :: ToBriDoc' HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do + HsModule _ Nothing _ imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) @@ -34,38 +41,43 @@ layoutModule lmod@(L _ mod') = case mod' of -- groupify commentedImports `forM_` tellDebugMessShow -- sortedImports <- sortImports imports let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- - mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack + allowSingleLineExportList <- mAsk + <&> _conf_layout + .> _lconfig_allowSingleLineExportList + .> confUnpack -- the config should not prevent single-line layout when there is no -- export list - let - allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les + let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les docLines $ docSeq [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative $ docLines + addAlternativeCond allowSingleLine $ + docForceSingleline + $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + addAlternative + $ docLines [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) - (docSeq - [ docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docSeq [ + docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + ) ] ] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] @@ -77,7 +89,7 @@ data CommentedImport instance Show CommentedImport where show = \case - EmptyLine -> "EmptyLine" + EmptyLine -> "EmptyLine" IndependentComment _ -> "IndependentComment" ImportStatement r -> "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show @@ -90,9 +102,8 @@ data ImportStatementRecord = ImportStatementRecord } instance Show ImportStatementRecord where - show r = - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) + show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) transformToCommentedImport :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] @@ -110,11 +121,10 @@ transformToCommentedImport is = do accumF accConnectedComm (annMay, decl) = case annMay of Nothing -> ( [] - , [ ImportStatement ImportStatementRecord - { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } + , [ ImportStatement ImportStatementRecord { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } ] ) Just ann -> @@ -126,7 +136,7 @@ transformToCommentedImport is = do :: [(Comment, DeltaPos)] -> [(Comment, DeltaPos)] -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) + go acc [] = ([], acc, 0) go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs go acc ((c1, DP (y, x)) : xs) = @@ -143,8 +153,8 @@ transformToCommentedImport is = do , convertedIndependentComments ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm , importStatement = decl } ] @@ -158,14 +168,14 @@ sortCommentedImports = where unpackImports :: [CommentedImport] -> [CommentedImport] unpackImports xs = xs >>= \case - l@EmptyLine -> [l] + l@EmptyLine -> [l] l@IndependentComment{} -> [l] ImportStatement r -> map IndependentComment (commentsBefore r) ++ [ImportStatement r] mergeGroups :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] mergeGroups xs = xs >>= \case - Left x -> [x] + Left x -> [x] Right y -> ImportStatement <$> y sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups = @@ -175,23 +185,25 @@ sortCommentedImports = groupify cs = go [] cs where go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest + (l@EmptyLine : rest) -> Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] + (ImportStatement r : rest) -> go [r] rest + [] -> [] go acc = \case (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : Right (reverse acc) : go [] rest (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] + [] -> [Right (reverse acc)] commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered commentedImportsToDoc = \case EmptyLine -> docLitS "" IndependentComment c -> commentToDoc c - ImportStatement r -> docSeq - (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) + ImportStatement r -> + docSeq + ( layoutImport (importStatement r) + : map commentToDoc (commentsAfter r) + ) where - commentToDoc (c, DP (_y, x)) = - docLitS (replicate x ' ' ++ commentContents c) + commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 88a10e4..4b99bca 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -3,19 +3,28 @@ module Language.Haskell.Brittany.Internal.Layouters.Pattern where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import qualified Data.Text as Text -import GHC (GenLocated(L), ol_val) -import GHC.Hs import qualified GHC.OldList as List -import GHC.Types.Basic -import Language.Haskell.Brittany.Internal.LayouterBasics + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import GHC ( GenLocated(L) + , ol_val + ) +import GHC.Hs +import GHC.Types.Basic + import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Layouters.Type + + -- | layouts patterns (inside function bindings, case alternatives, let -- bindings or do notation). E.g. for input @@ -29,15 +38,17 @@ import Language.Haskell.Brittany.Internal.Types -- the different cases below. layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr - VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n + VarPat _ n -> + fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit + LitPat _ lit -> + fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr ParPat _ inner -> do -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" + left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" innerDocs <- colsWrapPat =<< layoutPat inner return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right @@ -63,9 +74,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return <$> docLit nameDoc else do x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap - colsWrapPat - argDocs + xR <- fmap Seq.fromList + $ sequence + $ spacifyDocs + $ fmap colsWrapPat argDocs return $ x1 Seq.<| xR ConPat _ lname (InfixCon left right) -> do -- a :< b -> expr @@ -78,7 +90,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do + ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname @@ -91,34 +103,37 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName + , docSeq $ List.intersperse docCommaSep + $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName , docSeparator , docLit $ Text.pack "}" ] ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname - Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"] - ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) - | dotdoti == length fs -> do + Seq.singleton <$> docSeq + [ appSep $ docLit t + , docLit $ Text.pack "{..}" + ] + ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case (fieldName, Just fieldDoc) -> [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" @@ -126,13 +141,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docCommaSep ] (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] + , docLit $ Text.pack "..}" + ] TuplePat _ args boxity -> do -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR + Boxed -> wrapPatListy args "()" docParenL docParenR Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep AsPat _ asName asPat -> do -- bind@nestedpat -> expr @@ -169,11 +184,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of wrapPatPrepend pat1 (docLit $ Text.pack "~") NPat _ llit@(L _ ol) mNegative _ -> do -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val - ol + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] + Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat @@ -182,7 +196,9 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend - :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) + :: LPat GhcPs + -> ToBriDocM BriDocNumbered + -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of @@ -204,5 +220,8 @@ wrapPatListy elems both start end = do x1 Seq.:< rest -> do sDoc <- start eDoc <- end - rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd] + rest' <- rest `forM` \bd -> docSeq + [ docCommaSep + , return bd + ] return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 528853a..95f7273 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -4,19 +4,26 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L)) -import GHC.Hs -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text -import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( GenLocated(L) + ) +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Decl import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern + + layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt lstmt@(L _ stmt) = do @@ -46,12 +53,12 @@ layoutStmt lstmt@(L _ stmt) = do ] ] LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree + let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" + Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [bindDoc] -> docAlt [ -- let bind = expr docCols @@ -61,10 +68,9 @@ layoutStmt lstmt@(L _ stmt) = do f = case indentPolicy of IndentPolicyFree -> docSetBaseAndIndent IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple - | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc + IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc ] , -- let -- bind = expr @@ -78,11 +84,10 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (isFree || indentFourPlus) $ docSeq [ appSep $ docLit $ Text.pack "let" - , let - f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs + , let f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs ] -- let -- aaa = expra @@ -90,9 +95,8 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (not indentFourPlus) $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + $ docPar (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index fbba444..02b388c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -2,7 +2,14 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types + + +import Language.Haskell.Brittany.Internal.Prelude + +import Language.Haskell.Brittany.Internal.Types + +import GHC.Hs + + layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 7ccb461..ed0dd26 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -3,18 +3,28 @@ module Language.Haskell.Brittany.Internal.Layouters.Type where -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Utils.Outputable (ftext, showSDocUnsafe) -import Language.Haskell.Brittany.Internal.LayouterBasics + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - (FirstLastView(..), splitFirstLast) +import qualified Data.Text as Text +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Utils + ( splitFirstLast + , FirstLastView(..) + ) + +import GHC ( GenLocated(L) + , AnnKeywordId (..) + ) +import GHC.Hs +import GHC.Utils.Outputable ( ftext, showSDocUnsafe ) +import GHC.Types.Basic + + layoutType :: ToBriDoc HsType layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of @@ -22,66 +32,76 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsTyVar _ promoted name -> do t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of - IsPromoted -> - docSeq [docSeparator, docTick, docWrapNode name $ docLit t] + IsPromoted -> docSeq + [ docSeparator + , docTick + , docWrapNode name $ docLit t + ] NotPromoted -> docWrapNode name $ docLit t HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do let bndrs = getBinders hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs forallDoc = docAlt - [ let open = docLit $ Text.pack "forall" - in docSeq ([open] ++ tyVarDocLineList) + [ let + open = docLit $ Text.pack "forall" + in docSeq ([open]++tyVarDocLineList) , docPar - (docLit (Text.pack "forall")) - (docLines $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" - ] - ) + (docLit (Text.pack "forall")) + (docLines + $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ]) ] contextDoc = case cntxtDocs of [] -> docLit $ Text.pack "()" [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) , let - open = docCols - ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs + ] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) cntxtDoc + ] in docPar open $ docLines $ list ++ [close] ] docAlt -- :: forall a b c . (Foo a b c) => a b -> c [ docSeq [ if null bndrs - then docEmpty - else - let + then docEmpty + else let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) + in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) , docForceSingleline contextDoc , docLit $ Text.pack " => " , docForceSingleline typeDoc @@ -91,74 +111,75 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - forallDoc - (docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) $ contextDoc + forallDoc + ( docLines + [ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) + $ contextDoc + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] ] - , docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] - ] - ) + ) ] HsForAllTy _ hsf typ2 -> do let bndrs = getBinders hsf typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs docAlt -- forall x . x [ docSeq [ if null bndrs - then docEmpty - else - let + then docEmpty + else let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open] ++ tyVarDocLineList ++ [close]) + in docSeq ([open]++tyVarDocLineList++[close]) , docForceSingleline $ return $ typeDoc ] -- :: forall x -- . x , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ) -- :: forall -- (x :: *) -- . x , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> - docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ] + ) + ++[ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc ] + ] ) - ++ [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ] - ) ] HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do typeDoc <- docSharedWrapper layoutType typ1 @@ -169,27 +190,29 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) , let - open = docCols - ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) + $ head cntxtDocs + ] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) + $ cntxtDoc + ] in docPar open $ docLines $ list ++ [close] ] - let - maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id docAlt -- (Foo a b c) => a b -> c [ docSeq @@ -201,39 +224,37 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - (docForceSingleline contextDoc) - (docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) + (docForceSingleline contextDoc) + ( docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) ] HsFunTy _ _ typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id hasComments <- hasAnyCommentsBelow ltype - docAlt - $ [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 - ] - | not hasComments + docAlt $ + [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 ] - ++ [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 - ] - ) - ] + | not hasComments + ] ++ + [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) + $ maybeForceML typeDoc2 + ] + ) + ] HsParTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -243,28 +264,24 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack ")" ] , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack ")") + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack ")") ] HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let - gather - :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 - final -> (final, list) + let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 + final -> (final, list) let (typHead, typRest) = gather [typ2] typ1 docHead <- docSharedWrapper layoutType typHead docRest <- docSharedWrapper layoutType `mapM` typRest docAlt [ docSeq - $ docForceSingleline docHead - : (docRest >>= \d -> [docSeparator, docForceSingleline d]) + $ docForceSingleline docHead : (docRest >>= \d -> + [ docSeparator, docForceSingleline d ]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] HsAppTy _ typ1 typ2 -> do @@ -276,7 +293,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docSeparator , docForceSingleline typeDoc2 ] - , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) + , docPar + typeDoc1 + (docEnsureIndent BrIndentRegular typeDoc2) ] HsListTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 @@ -287,61 +306,51 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack "]" ] , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack "]") + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack "]") ] HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where - unboxed = if null typs - then error "brittany internal error: unboxed unit" - else unboxedL + unboxed = if null typs then error "brittany internal error: unboxed unit" + else unboxedL simple = if null typs then unitL else simpleL unitL = docLit $ Text.pack "()" simpleL = do docs <- docSharedWrapper layoutType `mapM` typs - let - end = docLit $ Text.pack ")" - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) + let end = docLit $ Text.pack ")" + lines = List.tail docs <&> \d -> + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt - [ docSeq - $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] + [ docSeq $ [docLit $ Text.pack "("] + ++ docWrapNodeRest ltype commaDocs + ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in - docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) + in docPar + (docAddBaseY (BrIndentSpecial 2) $ line1) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs - let - start = docParenHashLSep - end = docParenHashRSep + let start = docParenHashLSep + end = docParenHashRSep docAlt - [ docSeq - $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] + [ docSeq $ [start] + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) + ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] + lines = List.tail docs <&> \d -> + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ lines ++ [end]) @@ -410,18 +419,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack - ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + [ docWrapNodeRest ltype + $ docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") , docForceSingleline typeDoc1 ] , docPar - (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ] - ) + ( docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) + ) + (docCols ColTyOpPrefix + [ docWrapNodeRest ltype + $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ]) ] -- TODO: test KindSig HsKindSig _ typ1 kind1 -> do @@ -462,7 +473,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] else docPar typeDoc1 - (docCols + ( docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) kindDoc1 @@ -533,7 +544,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq - $ [docLit $ Text.pack "'["] + $ [docLit $ Text.pack "'["] ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"] , case splitFirstLast typDocs of @@ -558,23 +569,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse - specialCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) - ) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) ++ [docLit $ Text.pack " ]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] - lineN = docCols - ColList - [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> + docCols ColList [specialCommaSep, d] + lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype @@ -585,7 +592,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy NoSourceText _ -> error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> docLit $ Text.pack "_" + HsWildCardTy _ -> + docLit $ Text.pack "_" HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype HsStarTy _ isUnicode -> do @@ -598,12 +606,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of k <- docSharedWrapper layoutType kind docAlt [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar t (docSeq [docLit $ Text.pack "@", k]) + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar + t + (docSeq [docLit $ Text.pack "@", k ]) ] layoutTyVarBndrs diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs index b4785a5..29dc13c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -2,24 +2,28 @@ module Language.Haskell.Brittany.Internal.Obfuscation where -import Data.Char + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import System.Random + +import Data.Char +import System.Random + + obfuscate :: Text -> IO Text obfuscate input = do let predi x = isAlphaNum x || x `elem` "_'" let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let - exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x + let exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x let filtered = filter exceptionFilter idents mappings <- fmap Map.fromList $ filtered `forM` \x -> do r <- createAlias x @@ -71,14 +75,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] createAlias :: String -> IO String createAlias xs = go NoHint xs where - go _hint "" = pure "" - go hint (c : cr) = do + go _hint "" = pure "" + go hint (c : cr) = do c' <- case hint of VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr pure (c' : cr') diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs index 0790989..87a0c0a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,195 +1,346 @@ -module Language.Haskell.Brittany.Internal.Prelude - ( module E - ) where +module Language.Haskell.Brittany.Internal.Prelude ( module E ) where -import GHC.Hs.Extension as E (GhcPs) -import GHC.Types.Name.Reader as E (RdrName) -import Control.Applicative as E (Alternative(..), Applicative(..)) -import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) -import Control.Concurrent as E (forkIO, forkOS, threadDelay) -import Control.Concurrent.Chan as E (Chan) -import Control.Concurrent.MVar as E - (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) -import Control.Exception as E (assert, bracket, evaluate) -import Control.Monad as E - ( (<$!>) - , (<=<) - , (=<<) - , (>=>) - , Functor(..) - , Monad(..) - , MonadPlus(..) - , filterM - , forM - , forM_ - , forever - , guard - , join - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , mapM - , mapM_ - , replicateM - , replicateM_ - , sequence - , sequence_ - , unless - , void - , when - ) -import Control.Monad.Extra as E - (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) -import Control.Monad.IO.Class as E (MonadIO(..)) -import Control.Monad.ST as E (ST) -import Control.Monad.Trans.Class as E (lift) -import Control.Monad.Trans.Maybe as E (MaybeT(..)) -import Control.Monad.Trans.MultiRWS as E - (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) -import Data.Bifunctor as E (bimap) -import Data.Bool as E (Bool(..)) -import Data.Char as E (Char, chr, ord) -import Data.Data as E (toConstr) -import Data.Either as E (Either(..), either) -import Data.Foldable as E (asum, fold, foldl', foldr') -import Data.Function as E ((&), fix) -import Data.Functor as E (($>)) -import Data.Functor.Identity as E (Identity(..)) -import Data.IORef as E (IORef) -import Data.Int as E (Int) -import Data.List as E - ( all - , break - , drop - , dropWhile - , elem - , filter - , find - , intercalate - , intersperse - , isPrefixOf - , isSuffixOf - , iterate - , length - , mapAccumL - , mapAccumR - , maximum - , minimum - , notElem - , nub - , null - , partition - , repeat - , replicate - , sortBy - , sum - , take - , takeWhile - , transpose - , uncons - , unzip - , zip - , zip3 - , zipWith - ) -import Data.List.Extra as E (nubOrd, stripSuffix) -import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) -import Data.Map as E (Map) -import Data.Maybe as E - (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) -import Data.Monoid as E - ( All(..) - , Alt(..) - , Any(..) - , Endo(..) - , Monoid(..) - , Product(..) - , Sum(..) - , mconcat - ) -import Data.Ord as E (Down(..), Ordering(..), comparing) -import Data.Proxy as E (Proxy(..)) -import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) -import Data.Semigroup as E ((<>), Semigroup(..)) -import Data.Sequence as E (Seq) -import Data.Set as E (Set) -import Data.String as E (String) -import Data.Text as E (Text) -import Data.Tree as E (Tree(..)) -import Data.Tuple as E (swap) -import Data.Typeable as E (Typeable) -import Data.Version as E (showVersion) -import Data.Void as E (Void) -import Data.Word as E (Word, Word32) -import Debug.Trace as E - ( trace - , traceIO - , traceId - , traceM - , traceShow - , traceShowId - , traceShowM - , traceStack - ) -import Foreign.ForeignPtr as E (ForeignPtr) -import Foreign.Storable as E (Storable) -import GHC.Exts as E (Constraint) -import Prelude as E - ( ($) - , ($!) - , (&&) - , (++) - , (.) - , (<$>) - , Bounded(..) - , Double - , Enum(..) - , Eq(..) - , Float - , Floating(..) - , Foldable - , Fractional(..) - , Integer - , Integral(..) - , Num(..) - , Ord(..) - , RealFloat(..) - , RealFrac(..) - , Show(..) - , Traversable - , (^) - , and - , any - , const - , curry - , error - , flip - , foldl - , foldr - , foldr1 - , fromIntegral - , fst - , head - , id - , map - , not - , or - , otherwise - , print - , putStr - , putStrLn - , realToFrac - , reverse - , seq - , snd - , subtract - , traverse - , uncurry - , undefined - , (||) - ) -import System.IO as E (IO, hFlush, stdout) -import Text.Read as E (readMaybe) + +-- rather project-specific stuff: +--------------------------------- +import GHC.Hs.Extension as E ( GhcPs ) + +import GHC.Types.Name.Reader as E ( RdrName ) + + +-- more general: +---------------- + +import Data.Functor.Identity as E ( Identity(..) ) +import Control.Concurrent.Chan as E ( Chan ) +import Control.Concurrent.MVar as E ( MVar + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , takeMVar + , swapMVar + ) +import Data.Int as E ( Int ) +import Data.Word as E ( Word + , Word32 + ) +import Prelude as E ( Integer + , Float + , Double + , undefined + , Eq (..) + , Ord (..) + , Enum (..) + , Bounded (..) + , (<$>) + , (.) + , ($) + , ($!) + , Num (..) + , Integral (..) + , Fractional (..) + , Floating (..) + , RealFrac (..) + , RealFloat (..) + , fromIntegral + , error + , foldr + , foldl + , foldr1 + , id + , map + , subtract + , putStrLn + , putStr + , Show (..) + , print + , fst + , snd + , (++) + , not + , (&&) + , (||) + , curry + , uncurry + , flip + , const + , seq + , reverse + , otherwise + , traverse + , realToFrac + , or + , and + , head + , any + , (^) + , Foldable + , Traversable + ) +import Control.Monad.ST as E ( ST ) +import Data.Bool as E ( Bool(..) ) +import Data.Char as E ( Char + , ord + , chr + ) +import Data.Either as E ( Either(..) + , either + ) +import Data.IORef as E ( IORef ) +import Data.Maybe as E ( Maybe(..) + , fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + ) +import Data.Monoid as E ( Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + , Alt(..) + , mconcat + , Monoid (..) + ) +import Data.Ord as E ( Ordering(..) + , Down(..) + , comparing + ) +import Data.Ratio as E ( Ratio + , Rational + , (%) + , numerator + , denominator + ) +import Data.String as E ( String ) +import Data.Void as E ( Void ) +import System.IO as E ( IO + , hFlush + , stdout + ) +import Data.Proxy as E ( Proxy(..) ) +import Data.Sequence as E ( Seq ) + +import Data.Map as E ( Map ) +import Data.Set as E ( Set ) + +import Data.Text as E ( Text ) + +import Data.Function as E ( fix + , (&) + ) + +import Data.Foldable as E ( foldl' + , foldr' + , fold + , asum + ) + +import Data.List as E ( partition + , null + , elem + , notElem + , minimum + , maximum + , length + , all + , take + , drop + , find + , sum + , zip + , zip3 + , zipWith + , repeat + , replicate + , iterate + , nub + , filter + , intersperse + , intercalate + , isSuffixOf + , isPrefixOf + , dropWhile + , takeWhile + , unzip + , break + , transpose + , sortBy + , mapAccumL + , mapAccumR + , uncons + ) + +import Data.List.NonEmpty as E ( NonEmpty(..) + , nonEmpty + ) + +import Data.Tuple as E ( swap + ) + +import Text.Read as E ( readMaybe + ) + +import Control.Monad as E ( Functor (..) + , Monad (..) + , MonadPlus (..) + , mapM + , mapM_ + , forM + , forM_ + , sequence + , sequence_ + , (=<<) + , (>=>) + , (<=<) + , forever + , void + , join + , replicateM + , replicateM_ + , guard + , when + , unless + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , filterM + , (<$!>) + ) + +import Control.Applicative as E ( Applicative (..) + , Alternative (..) + ) + +import Foreign.Storable as E ( Storable ) +import GHC.Exts as E ( Constraint ) + +import Control.Concurrent as E ( threadDelay + , forkIO + , forkOS + ) + +import Control.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.Bifunctor as E ( bimap ) +import Data.Functor as E ( ($>) ) +import Data.Semigroup as E ( (<>) + , Semigroup(..) + ) + +import Data.Typeable as E ( Typeable + ) + +import Control.Arrow as E ( first + , second + , (***) + , (&&&) + , (>>>) + , (<<<) + ) + +import Data.Version as E ( showVersion + ) + +import Data.List.Extra as E ( nubOrd + , stripSuffix + ) +import Control.Monad.Extra as E ( whenM + , unlessM + , ifM + , notM + , orM + , andM + , anyM + , allM + ) + +import Data.Tree as E ( Tree(..) + ) + +import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) + -- , MultiRWSTNull + -- , MultiRWS + -- , + MonadMultiReader(..) + , MonadMultiWriter(..) + , MonadMultiState(..) + , mGet + -- , runMultiRWST + -- , runMultiRWSTASW + -- , runMultiRWSTW + -- , runMultiRWSTAW + -- , runMultiRWSTSW + -- , runMultiRWSTNil + -- , runMultiRWSTNil_ + -- , withMultiReader + -- , withMultiReader_ + -- , withMultiReaders + -- , withMultiReaders_ + -- , withMultiWriter + -- , withMultiWriterAW + -- , withMultiWriterWA + -- , withMultiWriterW + -- , withMultiWriters + -- , withMultiWritersAW + -- , withMultiWritersWA + -- , withMultiWritersW + -- , withMultiState + -- , withMultiStateAS + -- , withMultiStateSA + -- , withMultiStateA + -- , withMultiStateS + -- , withMultiState_ + -- , withMultiStates + -- , withMultiStatesAS + -- , withMultiStatesSA + -- , withMultiStatesA + -- , withMultiStatesS + -- , withMultiStates_ + -- , inflateReader + -- , inflateMultiReader + -- , inflateWriter + -- , inflateMultiWriter + -- , inflateState + -- , inflateMultiState + -- , mapMultiRWST + -- , mGetRawR + -- , mGetRawW + -- , mGetRawS + -- , mPutRawR + -- , mPutRawW + -- , mPutRawS + ) + +import Control.Monad.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/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs index fcfe303..cfaed43 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -1,15 +1,21 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Brittany.Internal.PreludeUtils where -import Control.Applicative -import Control.DeepSeq (NFData, force) -import Control.Exception.Base (evaluate) -import Control.Monad + + +import Prelude import qualified Data.Strict.Maybe as Strict import Debug.Trace -import Prelude +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) @@ -24,12 +30,12 @@ instance Alternative Strict.Maybe where x <|> Strict.Nothing = x _ <|> x = x -traceFunctionWith - :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +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 + traceStr = + name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y (<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) = flip (<$!>) @@ -45,10 +51,10 @@ printErr = putStrErrLn . show errorIf :: Bool -> a -> a errorIf False = id -errorIf True = error "errorIf" +errorIf True = error "errorIf" errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id +errorIfNote Nothing = id errorIfNote (Just x) = error x (<&>) :: Functor f => f a -> (a -> b) -> f b diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 1fd3eb7..ca79995 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -9,18 +9,25 @@ module Language.Haskell.Brittany.Internal.Transformations.Alt where -import qualified Control.Monad.Memo as Memo + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.HList.ContainsType import qualified Data.List.Extra import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Data.HList.ContainsType + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Control.Monad.Memo as Memo + + data AltCurPos = AltCurPos { _acp_line :: Int -- chars in the current line @@ -28,7 +35,7 @@ data AltCurPos = AltCurPos , _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_forceMLFlag :: AltLineModeState } - deriving Show + deriving (Show) data AltLineModeState = AltLineModeStateNone @@ -39,19 +46,17 @@ data AltLineModeState deriving (Show) altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = - AltLineModeStateContradiction +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone -altLineModeDecay (AltLineModeStateForceML False) = - AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of @@ -76,7 +81,7 @@ transformAlts = . Memo.startEvalMemoT . fmap unwrapBriDocNumbered . rec - where + where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) -- transWrap :: BriDoc -> BriDocNumbered @@ -114,246 +119,224 @@ transformAlts = - rec - :: BriDocNumbered - -> Memo.MemoT - Int - [VerticalSpacing] - (MultiRWSS.MultiRWS r w (AltCurPos ': s)) - BriDocNumbered - rec bdX@(brDcId, brDc) = do - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let - indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- - mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let - lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk - let - options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - (hasSpace1 lconf acp vs && lineCheck vs, bd) - ) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust - (\(_i :: Int, (b, x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ] - ) - $ zip [1 ..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let - lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk - let - options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) - ) - let - checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered + rec bdX@(brDcId, brDc) = do + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> + reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> + reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd mSet $ acp - { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp + { _acp_indent = ind + , _acp_indentPrep = 0 } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do + sameLine' <- rec sameLine + mModify $ \acp' -> acp' + { _acp_line = ind + , _acp_indent = ind + } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( hasSpace1 lconf acp vs && lineCheck vs, bd)) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ]) + $ zip [1..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let lineCheck (VerticalSpacing _ p _) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( any (hasSpace2 lconf acp) vs + && any lineCheck vs, bd)) + let checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l:lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp + { _acp_line = ind + , _acp_indent = ind + } + rec x + return $ reWrap $ BDFLines (l':lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing _ bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do acp <- mGet - mSet $ acp - { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp - } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l : lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } - rec x - return $ reWrap $ BDFLines (l' : lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> - reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess - $ "transformAlts: BDFDEBUG " - ++ s - ++ " (node-id=" - ++ show brDcId - ++ "): acp=" - ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do - acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 - :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line - + sameLine - <= confUnpack (_lconfig_cols lconf) - && indent - + indentPrep - + par - <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) getSpacing :: forall m @@ -370,11 +353,10 @@ getSpacing !bridoc = rec bridoc -- BDWrapAnnKey _annKey bd -> rec bd BDFEmpty -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> return $ LineModeValid $ VerticalSpacing - (Text.length t) - VerticalSpacingParNone - False - BDFSeq list -> sumVs <$> rec `mapM` list + BDFLit t -> + return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False + BDFSeq list -> + sumVs <$> rec `mapM` list BDFCols _sig list -> sumVs <$> rec `mapM` list BDFSeparator -> return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False @@ -382,28 +364,22 @@ getSpacing !bridoc = rec bridoc mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> - VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> - VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j } BDFBaseYPushCur bd -> do @@ -414,13 +390,11 @@ getSpacing !bridoc = rec bridoc -- the reason is that we really want to _keep_ it Just if it is -- just so we properly communicate the is-multiline fact. -- An alternative would be setting to (Just 0). - { _vs_sameLine = max - (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i - ) + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) , _vs_paragraph = VerticalSpacingParSome 0 } BDFBaseYPop bd -> rec bd @@ -434,104 +408,86 @@ getSpacing !bridoc = rec bridoc | VerticalSpacing lsp mPsp _ <- mVs , indSp <- mIndSp , lineMax <- getMaxVS $ mIndSp - , let - pspResult = case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp lineMax - , let - parFlagResult = - mPsp - == VerticalSpacingParNone - && _vs_paragraph indSp - == VerticalSpacingParNone - && _vs_parFlag indSp + , let pspResult = case mPsp of + VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax + , let parFlagResult = mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp ] BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt : _) -> rec alt - BDFForceMultiline bd -> do + BDFAlt (alt:_) -> rec alt + BDFForceMultiline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> LineModeInvalid - _ -> mVs + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> mVs - _ -> LineModeInvalid + _ -> LineModeInvalid BDFForwardLineMode bd -> rec bd BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_ : _) -> do + BDFLines [] -> return + $ LineModeValid + $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_:_) -> do lSps <- rec `mapM` ls - let (mVs : _) = lSps -- separated into let to avoid MonadFail - return - $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] + let (mVs:_) = lSps -- separated into let to avoid MonadFail + return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] BDFEnsureIndent indent bd -> do mVs <- rec bd - let - addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config - BrIndentSpecial i -> i + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf BDFNonBottomSpacing b bd -> do mVs <- rec bd - return $ mVs <|> LineModeValid - (VerticalSpacing - 0 - (if b - then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) + return + $ mVs + <|> LineModeValid + (VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } BDFForceParSpacing bd -> do mVs <- rec bd - return - $ [ vs - | vs <- mVs - , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone - ] + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] BDFDebug s bd -> do r <- rec bd - tellDebugMess - $ "getSpacing: BDFDebug " - ++ show s - ++ " (node-id=" - ++ show brDcId - ++ "): mVs=" - ++ show r + tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r return r return result - maxVs - :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs = foldl' - (liftM2 - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of + (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing (max x1 y1) (case (x2, y2) of (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> @@ -541,14 +497,9 @@ getSpacing !bridoc = rec bridoc (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> VerticalSpacingParAlways $ max i j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y - ) - False - ) - ) + VerticalSpacingParSome $ max x y) False)) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs - :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing sumVs sps = foldl' (liftM2 go) initial sps where go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing @@ -557,19 +508,18 @@ getSpacing !bridoc = rec bridoc (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j + VerticalSpacingParAlways $ i+j (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j + VerticalSpacingParAlways $ i+j (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j + VerticalSpacingParAlways $ i+j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) + VerticalSpacingParSome $ x + y) x3 singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False + singleline _ = False isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False + isPar _ = False parFlag = case sps of [] -> True _ -> all singleline (List.init sps) && isPar (List.last sps) @@ -589,395 +539,374 @@ getSpacings -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where + where -- when we do `take K . filter someCondition` on a list of spacings, we -- need to first (also) limit the size of the input list, otherwise a -- _large_ input with a similarly _large_ prefix not passing our filtering -- process could lead to exponential runtime behaviour. -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3 * limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec - :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let - hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let - specialCompare vs1 vs2 = - if ((_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let - allowHangingQuasiQuotes = - config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = - take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return - $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> - VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> - VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max - (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i - ) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] - return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp - ) - (mPsp - == VerticalSpacingParNone - && _vs_paragraph indSp - == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return - $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1] -> - VerticalSpacing (Text.length t1) VerticalSpacingParNone False - (t1 : _) -> VerticalSpacing - (Text.length t1) - (VerticalSpacingParAlways 0) - True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_ : _) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let - worbled = fmap reverse $ sequence $ reverse $ lSpss - sumF lSps@(lSp1 : _) = - VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False - sumF [] = - error - $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let - addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then - [ VerticalSpacing - 0 - (if b - then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3*limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let hasOkColCount (VerticalSpacing lsp psp _) = + lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let specialCompare vs1 vs2 = + if ( (_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let allowHangingQuasiQuotes = + config + & _conf_layout + & _lconfig_allowHangingQuasiQuotes + & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . specialNub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFSeparator -> + return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return - $ [ vs - | vs <- mVs - , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone - ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess - $ "getSpacings: BDFDebug " - ++ show s - ++ " (node-id=" - ++ show brDcId - ++ "): vs=" - ++ show (take 9 r) - return r - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y - ) - False - ) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit + $ [ (x,y) + | x<-mVss + , y<-indSps + ] + return $ mVsIndSp <&> + \(VerticalSpacing lsp mPsp _, indSp) -> + VerticalSpacing + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp) + ( mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> + return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1 ] -> VerticalSpacing + (Text.length t1) + VerticalSpacingParNone + False + (t1 : _) -> VerticalSpacing + (Text.length t1) + (VerticalSpacingParAlways 0) + True + | allowHangingQuasiQuotes + ] + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_:_) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- map filterAndLimit <$> rec `mapM` ls + let worbled = fmap reverse + $ sequence + $ reverse + $ lSpss + sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + sumF [] = error $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. + mVs <- rec bd + return $ if null mVs + then [VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] + else mVs <&> \vs -> vs + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) + return r + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) + False) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i fixIndentationForMultiple :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int fixIndentationForMultiple acp indent = do indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let - indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i + let indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i -- for IndentPolicyMultiple, we restrict the amount of added -- indentation in such a manner that we end up on a multiple of the -- base indentation. indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack pure $ if indPolicy == IndentPolicyMultiple then - let - indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 + let indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 5229134..89a2c6f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -3,10 +3,16 @@ module Language.Haskell.Brittany.Internal.Transformations.Columns where -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List + + import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + transformSimplifyColumns :: BriDoc -> BriDoc transformSimplifyColumns = Uniplate.rewrite $ \case @@ -14,150 +20,118 @@ transformSimplifyColumns = Uniplate.rewrite $ \case -- BDWrapAnnKey annKey $ transformSimplify bd BDEmpty -> Nothing BDLit{} -> Nothing - BDSeq list - | any - (\case - BDSeq{} -> True - BDEmpty{} -> True - _ -> False - ) - list - -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_ : _) : rest) - | all - (\case - BDSeparator -> True - _ -> False - ) - rest - -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)]) - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDSeq list | any (\case BDSeq{} -> True + BDEmpty{} -> True + _ -> False) list -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) + | all (\case BDSeparator -> True; _ -> False) rest -> + Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) + BDLines lines | any (\case BDLines{} -> True + BDEmpty{} -> True + _ -> False) lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l x -> [x] -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) -- post floating in BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] -- ensureIndent float-in -- not sure if the following rule is necessary; tests currently are -- unaffected. -- BDEnsureIndent indent (BDLines lines) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines -- matching col special transformation - BDCols sig1 cols1@(_ : _) - | BDLines lines@(_ : _ : _) <- List.last cols1 + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 , BDCols sig2 cols2 <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_ : _) - | BDLines lines@(_ : _ : _) <- List.last cols1 + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) - | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) + | sig1==sig2 -> + Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just - $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) - | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just - $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- | sig1==sig2 -> -- Just $ BDPar -- ind1 -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols - | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 - -> Just - $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] - BDCols sig1 cols - | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 - $ List.init cols - ++ [BDPar ind line (BDLines $ List.init lines)] + BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 (List.init cols ++ [line]) , BDCols sig2 cols2 ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing + BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] + , BDCols sig2 cols2 + ] + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing BDForceSingleline{} -> Nothing BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing + BDExternal{} -> Nothing + BDPlain{} -> Nothing + BDLines{} -> Nothing BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing + BDDebug{} -> Nothing BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index c320dbf..0231306 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -3,20 +3,25 @@ module Language.Haskell.Brittany.Internal.Transformations.Floating where -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + -- note that this is not total, and cannot be with that exact signature. mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = - BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" transformSimplifyFloating :: BriDoc -> BriDoc @@ -26,192 +31,169 @@ transformSimplifyFloating = stepBO .> stepFull -- better complexity. -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just - $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> Just x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> Just $ x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + BDAddBaseY BrIndentNone x -> + Just x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> + Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + BDAddBaseY BrIndentNone x -> + Just $ x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 9596e5b..7f7d7e5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -3,10 +3,16 @@ module Language.Haskell.Brittany.Internal.Transformations.Indent where -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List + + import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + -- prepare layouting by translating BDPar's, replacing them with Indents and -- floating those in. This gives a more clear picture of what exactly is @@ -25,17 +31,15 @@ transformSimplifyIndent = Uniplate.rewrite $ \case -- [ BDAddBaseY ind x -- , BDEnsureIndent ind indented -- ] - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l - x -> [x] + x -> [x] BDLines [l] -> Just l BDAddBaseY i (BDAnnotationPrior k x) -> Just $ BDAnnotationPrior k (BDAddBaseY i x) @@ -49,4 +53,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY _ lit@BDLit{} -> Just lit - _ -> Nothing + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 7fb4aff..305ee08 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -3,9 +3,14 @@ module Language.Haskell.Brittany.Internal.Transformations.Par where + + import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Types + + transformSimplifyPar :: BriDoc -> BriDoc transformSimplifyPar = transformUp $ \case @@ -19,28 +24,25 @@ transformSimplifyPar = transformUp $ \case BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs where go = (=<<) $ \case BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x -- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- BDPar BrIndentNone line indented -> -- Just $ BDLines [line, indented] BDEnsureIndent BrIndentNone x -> x - x -> x + x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 41d809b..76b7735 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -12,47 +12,52 @@ module Language.Haskell.Brittany.Internal.Types where + + +import Language.Haskell.Brittany.Internal.Prelude import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data -import Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Kind as Kind import qualified Data.Strict.Maybe as Strict -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint (AnnKey) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types (Anns) import qualified Safe +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan ) + +import Language.Haskell.GHC.ExactPrint ( AnnKey ) +import Language.Haskell.GHC.ExactPrint.Types ( Anns ) + +import Language.Haskell.Brittany.Internal.Config.Types + +import Data.Generics.Uniplate.Direct as Uniplate + +import qualified Data.Kind as Kind + + + data PerItemConfig = PerItemConfig { _icd_perBinding :: Map String (CConfig Maybe) , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) } deriving Data.Data.Data -type PPM - = MultiRWSS.MultiRWS - '[ Map ExactPrint.AnnKey ExactPrint.Anns - , PerItemConfig - , Config - , ExactPrint.Anns - ] - '[Text.Builder.Builder , [BrittanyError] , Seq String] - '[] +type PPM = MultiRWSS.MultiRWS + '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] -type PPMLocal - = MultiRWSS.MultiRWS - '[Config , ExactPrint.Anns] - '[Text.Builder.Builder , [BrittanyError] , Seq String] - '[] +type PPMLocal = MultiRWSS.MultiRWS + '[Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) data LayoutState = LayoutState - { _lstate_baseYs :: [Int] + { _lstate_baseYs :: [Int] -- ^ stack of number of current indentation columns -- (not number of indentations). , _lstate_curYOrAddNewline :: Either Int Int @@ -60,7 +65,7 @@ data LayoutState = LayoutState -- 1) number of chars in the current line. -- 2) number of newlines to be inserted before inserting any -- non-space elements. - , _lstate_indLevels :: [Int] + , _lstate_indLevels :: [Int] -- ^ stack of current indentation levels. set for -- any layout-affected elements such as -- let/do/case/where elements. @@ -73,14 +78,14 @@ data LayoutState = LayoutState -- on the first indented element have an -- annotation offset relative to the last -- non-indented element, which is confusing. - , _lstate_comments :: Anns - , _lstate_commentCol :: Maybe Int -- this communicates two things: + , _lstate_comments :: Anns + , _lstate_commentCol :: Maybe Int -- this communicates two things: -- firstly, that cursor is currently -- at the end of a comment (so needs -- newline before any actual content). -- secondly, the column at which -- insertion of comments started. - , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone + , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone -- writes (any non-spaces) in the -- current line. -- , _lstate_isNewline :: NewLineState @@ -110,21 +115,14 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels instance Show LayoutState where show state = "LayoutState" - ++ "{baseYs=" - ++ show (_lstate_baseYs state) - ++ ",curYOrAddNewline=" - ++ show (_lstate_curYOrAddNewline state) - ++ ",indLevels=" - ++ show (_lstate_indLevels state) - ++ ",indLevelLinger=" - ++ show (_lstate_indLevelLinger state) - ++ ",commentCol=" - ++ show (_lstate_commentCol state) - ++ ",addSepSpace=" - ++ show (_lstate_addSepSpace state) - ++ ",commentNewlines=" - ++ show (_lstate_commentNewlines state) - ++ "}" + ++ "{baseYs=" ++ show (_lstate_baseYs state) + ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) + ++ ",indLevels=" ++ show (_lstate_indLevels state) + ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) + ++ ",commentCol=" ++ show (_lstate_commentCol state) + ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) + ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- -- newline, really. by special-casing @@ -225,16 +223,14 @@ data BrIndent = BrIndentNone | BrIndentSpecial Int deriving (Eq, Ord, Data.Data.Data, Show) -type ToBriDocM - = MultiRWSS.MultiRWS - '[Config , Anns] -- reader - '[[BrittanyError] , Seq String] -- writer - '[NodeAllocIndex] -- state +type ToBriDocM = MultiRWSS.MultiRWS + '[Config, Anns] -- reader + '[[BrittanyError], Seq String] -- writer + '[NodeAllocIndex] -- state -type ToBriDoc (sym :: Kind.Type -> Kind.Type) - = Located (sym GhcPs) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c +type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = Located sym -> ToBriDocM c data DocMultiLine = MultiLineNo @@ -342,21 +338,21 @@ type BriDocFInt = BriDocF ((,) Int) type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = @@ -365,84 +361,83 @@ instance Uniplate.Uniplate BriDoc where plate BDAnnotationRest |- annKey |* bd uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd) = plate BDDebug |- s |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int -- TODO: rename to "dropLabels" ? unwrapBriDocNumbered :: BriDocNumbered -> BriDoc unwrapBriDocNumbered tpl = case snd tpl of - BDFEmpty -> BDEmpty - BDFLit t -> BDLit t - BDFSeq list -> BDSeq $ rec <$> list - BDFCols sig list -> BDCols sig $ rec <$> list - BDFSeparator -> BDSeparator - BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDFBaseYPop bd -> BDBaseYPop $ rec bd - BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDFPar ind line indented -> BDPar ind (rec line) (rec indented) - BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDFForwardLineMode bd -> BDForwardLineMode $ rec bd - BDFExternal k ks c t -> BDExternal k ks c t - BDFPlain t -> BDPlain t + BDFEmpty -> BDEmpty + BDFLit t -> BDLit t + BDFSeq list -> BDSeq $ rec <$> list + BDFCols sig list -> BDCols sig $ rec <$> list + BDFSeparator -> BDSeparator + BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDFBaseYPop bd -> BDBaseYPop $ rec bd + BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDFPar ind line indented -> BDPar ind (rec line) (rec indented) + BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDFForwardLineMode bd -> BDForwardLineMode $ rec bd + BDFExternal k ks c t -> BDExternal k ks c t + BDFPlain t -> BDPlain t BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd - BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd - BDFLines lines -> BDLines $ rec <$> lines - BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd + BDFLines lines -> BDLines $ rec <$> lines + BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False -isNotEmpty _ = True +isNotEmpty _ = True -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd - BDPar _ind line indented -> - briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDPlain{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd + BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented + BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDPlain{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd @@ -461,19 +456,18 @@ data VerticalSpacingPar -- product like (Normal|Always, None|Some Int). deriving (Eq, Show) -data VerticalSpacing = VerticalSpacing - { _vs_sameLine :: !Int - , _vs_paragraph :: !VerticalSpacingPar - , _vs_parFlag :: !Bool - } +data VerticalSpacing + = VerticalSpacing + { _vs_sameLine :: !Int + , _vs_paragraph :: !VerticalSpacingPar + , _vs_parFlag :: !Bool + } deriving (Eq, Show) newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) deriving (Functor, Applicative, Monad, Show, Alternative) -pattern LineModeValid :: forall t . t -> LineModeValidity t -pattern LineModeValid x = - LineModeValidity (Strict.Just x) :: LineModeValidity t -pattern LineModeInvalid :: forall t . LineModeValidity t -pattern LineModeInvalid = - LineModeValidity Strict.Nothing :: LineModeValidity t +pattern LineModeValid :: forall t. t -> LineModeValidity t +pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t +pattern LineModeInvalid :: forall t. LineModeValidity t +pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index a52caa4..a12f7ea 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -7,29 +7,40 @@ module Language.Haskell.Brittany.Internal.Utils where -import qualified Data.ByteString as B -import qualified Data.Coerce -import Data.Data -import Data.Generics.Aliases -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import DataTreePrint -import qualified GHC.Data.FastString as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Hs.Extension as HsExtension -import qualified GHC.OldList as List -import GHC.Types.Name.Occurrence as OccName (occNameString) -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Utils.Outputable as GHC -import Language.Haskell.Brittany.Internal.Config.Types + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import qualified Data.Coerce +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified GHC.OldList as List + import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils + +import Data.Data +import Data.Generics.Aliases + import qualified Text.PrettyPrint as PP +import qualified GHC.Utils.Outputable as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.Name.Occurrence as OccName ( occNameString ) +import qualified Data.ByteString as B + +import DataTreePrint + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.Hs.Extension as HsExtension + + + parDoc :: String -> PP.Doc parDoc = PP.fsep . fmap PP.text . List.words @@ -44,8 +55,7 @@ showOutputable :: (GHC.Outputable a) => a -> String showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = - Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y +fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity x y = @@ -60,26 +70,24 @@ instance (Num a, Ord a) => Semigroup (Max a) where (<>) = Data.Coerce.coerce (max :: a -> a -> a) instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 + mempty = Max 0 mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data -instance Show ShowIsId where - show (ShowIsId x) = x +instance Show ShowIsId where show (ShowIsId x) = x -data A x = A ShowIsId x - deriving Data +data A x = A ShowIsId x deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -87,22 +95,18 @@ customLayouterF anns layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = - simpleLayouter + srcSpan ss = simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" - ++ showOutputable ss - ++ "}" + $ "{" ++ showOutputable ss ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where @@ -114,12 +118,12 @@ customLayouterF anns layoutF = customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -127,15 +131,14 @@ customLayouterNoAnnsF layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter @@ -199,11 +202,12 @@ traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () -tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () +tellDebugMess :: MonadMultiWriter + (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s -tellDebugMessShow - :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () +tellDebugMessShow :: forall a m . (MonadMultiWriter + (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. @@ -218,28 +222,29 @@ briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = - printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) +annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1 : aR) = case fn a1 of - Left b -> (b : bs, cs) +breakEither _ [] = ([], []) +breakEither fn (a1:aR) = case fn a1 of + Left b -> (b : bs, cs) Right c -> (bs, c : cs) - where (bs, cs) = breakEither fn aR + where + (bs, cs) = breakEither fn aR spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) - where (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) +spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) + where + (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) data FirstLastView a = FirstLastEmpty @@ -249,7 +254,7 @@ data FirstLastView a splitFirstLast :: [a] -> FirstLastView a splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) +splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) -- TODO: move to uniplate upstream? -- aka `transform` @@ -268,7 +273,7 @@ lines' :: String -> [String] lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] - (s1, (_ : r)) -> s1 : lines' r + (s1, (_:r)) -> s1 : lines' r absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index 7f22f11..87ebe66 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -4,41 +4,58 @@ module Language.Haskell.Brittany.Main where -import Control.Monad (zipWithM) + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.Except as ExceptT -import Data.CZipWith import qualified Data.Either import qualified Data.List.Extra -import qualified Data.Monoid import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy as TextL -import DataTreePrint -import GHC (GenLocated(L)) -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List -import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Obfuscation -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Paths_brittany -import qualified System.Directory as Directory -import qualified System.Exit -import qualified System.FilePath.Posix as FilePath import qualified System.IO -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Text.PrettyPrint as PP -import Text.Read (Read(..)) -import UI.Butcher.Monadic + +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Data.Monoid + +import GHC ( GenLocated(L) ) +import GHC.Utils.Outputable ( Outputable(..) + , showSDocUnsafe + ) + +import Text.Read ( Read(..) ) +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec + +import Control.Monad ( zipWithM ) +import Data.CZipWith + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Obfuscation + +import qualified Text.PrettyPrint as PP + +import DataTreePrint +import UI.Butcher.Monadic + +import qualified System.Exit +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Paths_brittany + + data WriteMode = Display | Inplace @@ -93,7 +110,7 @@ helpDoc = PP.vcat $ List.intersperse ] , parDoc $ "See https://github.com/lspitzner/brittany" , parDoc - $ "Please report bugs at" + $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" ] @@ -130,16 +147,15 @@ mainCmdParser helpDesc = do addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams - "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser + configPaths <- addFlagStringParams "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] @@ -165,7 +181,7 @@ mainCmdParser helpDesc = do "" ["write-mode"] "(display|inplace)" - (flagHelp + ( flagHelp (PP.vcat [ PP.text "display: output for any input(s) goes to stdout" , PP.text "inplace: override respective input file (without backup!)" @@ -195,13 +211,11 @@ mainCmdParser helpDesc = do $ ppHelpShallow helpDesc System.Exit.exitSuccess - let - inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let - outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths + let inputPaths = + if null inputParams then [Nothing] else map Just inputParams + let outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths configsToLoad <- liftIO $ if null configPaths then @@ -216,15 +230,14 @@ mainCmdParser helpDesc = do ) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x + Just x -> return x when (config & _conf_debug & _dconf_dump_config & confUnpack) $ trace (showConfigYaml config) $ return () - results <- zipWithM - (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths + results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths if checkMode then when (Changes `elem` (Data.Either.rights results)) @@ -253,65 +266,58 @@ coreIO -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = ExceptT.runExceptT $ do - let - putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let ghcOptions = config & _conf_forward & _options_ghc & runIdentity -- there is a good of code duplication between the following code and the -- `pureModuleTransform` function. Unfortunately, there are also a good -- amount of slight differences: This module is a bit more verbose, and -- it tries to use the full-blown `parseModule` function which supports -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack -- the flag will do the following: insert a marker string -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- "#include" before processing (parsing) input; and remove that marker -- string from the transformation output. -- The flag is intentionally misspelled to prevent clashing with -- inline-config stuff. - let - hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let - exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + let hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic - let - hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let - hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id inputString <- liftIO System.IO.getContents - parseRes <- liftIO $ parseModuleFromString - ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) + parseRes <- liftIO $ parseModuleFromString ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) return (parseRes, Text.pack inputString) Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc + parseRes <- parseModule ghcOptions p cppCheckFunc inputText <- Text.IO.readFile p -- The above means we read the file twice, but the -- GHC API does not really expose the source it @@ -340,12 +346,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = pure c let moduleConf = cZipWith fromOptionIdentity config inlineConf when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let - val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () - let - disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack + let disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack (errsWarns, outSText, hasChanges) <- do if | disableFormatting -> do @@ -354,52 +358,46 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let r = Text.pack $ ExactPrint.exactPrint parsedSource anns pure ([], r, r /= originalContents) | otherwise -> do - let - omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck - moduleConf - perItemConf - anns - parsedSource - let - hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let - out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - else outRaw + else liftIO $ pPrintModuleAndCheck moduleConf + perItemConf + anns + parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out pure $ (ews, out', out' /= originalContents) - let - customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 unless (null errsWarns) $ do - let - groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns + let groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns groupedErrsWarns `forM_` \case (ErrorOutputCheck{} : _) -> do putErrorLn - $ "ERROR: brittany pretty printer" + $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str @@ -408,10 +406,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ "WARNING: encountered unknown syntactical constructs:" uns `forM_` \case ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe - (ppr loc) + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) when - (config + ( config & _conf_debug & _dconf_dump_ast_unknown & confUnpack @@ -425,17 +422,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = putErrorLn $ "WARNINGS:" warns `forM_` \case LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" unused@(ErrorUnusedComment{} : _) -> do putErrorLn - $ "Error: detected unprocessed comments." + $ "Error: detected unprocessed comments." ++ " The transformation output will most likely" ++ " not contain some of the comments" ++ " present in the input haskell source file." putErrorLn $ "Affected are the following comments:" unused `forM_` \case ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" (ErrorMacroConfig err input : _) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err @@ -446,8 +443,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let hasErrors = if config & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) outputOnErrs = config & _conf_errorHandling @@ -462,11 +459,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ addTraceSep (_conf_debug config) $ case outputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let - isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges + Just p -> liftIO $ do + let isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText when (checkMode && hasChanges) $ case inputPathM of @@ -478,15 +474,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = where addTraceSep conf = if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] then trace "----" else id diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index a39eecf..774088f 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -2,24 +2,35 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE ScopedTypeVariables #-} -import Data.Coerce (coerce) -import Data.List (groupBy) +import Language.Haskell.Brittany.Internal.Prelude import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified System.Directory -import System.FilePath (()) -import System.Timeout (timeout) -import Test.Hspec -import qualified Text.Parsec as Parsec -import Text.Parsec.Text (Parser) + +import Test.Hspec + +import qualified Text.Parsec as Parsec +import Text.Parsec.Text ( Parser ) + +import Data.List ( groupBy ) + +import Language.Haskell.Brittany.Internal + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config + +import Data.Coerce ( coerce ) + +import qualified Data.Text.IO as Text.IO +import System.FilePath ( () ) + +import System.Timeout ( timeout ) + + + +import Language.Haskell.Brittany.Internal.PreludeUtils hush :: Either a b -> Maybe b hush = either (const Nothing) Just @@ -29,32 +40,32 @@ hush = either (const Nothing) Just asymptoticPerfTest :: Spec asymptoticPerfTest = do it "10 do statements" - $ roundTripEqualWithTimeout 1500000 - $ (Text.pack "func = do\n") + $ roundTripEqualWithTimeout 1500000 + $ (Text.pack "func = do\n") <> Text.replicate 10 (Text.pack " statement\n") it "10 do nestings" - $ roundTripEqualWithTimeout 4000000 - $ (Text.pack "func = ") + $ roundTripEqualWithTimeout 4000000 + $ (Text.pack "func = ") <> mconcat - ([1 .. 10] <&> \(i :: Int) -> - (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") + ( [1 .. 10] + <&> \(i :: Int) -> + (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") ) <> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n" <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" it "10 AppOps" - $ roundTripEqualWithTimeout 1000000 - $ (Text.pack "func = expr") + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = expr") <> Text.replicate 10 (Text.pack "\n . expr") --TODO roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust) + timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) where - action = fmap - (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + action = fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) data InputLine @@ -74,11 +85,10 @@ data TestCase = TestCase main :: IO () main = do files <- System.Directory.listDirectory "data/" - let - blts = - List.sort - $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt" `isSuffixOf`) files + let blts = + List.sort + $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) + $ filter (".blt" `isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("data" blt) let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt" @@ -89,17 +99,15 @@ main = do it "gives properly formatted result for valid input" $ do let input = Text.pack $ unlines - [ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]" - ] - let - expected = Text.pack $ unlines - [ "func =" - , " [ 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " ]" - ] + ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] + let expected = Text.pack $ unlines + [ "func =" + , " [ 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " ]" + ] output <- liftIO $ parsePrintModule staticDefaultConfig input hush output `shouldBe` Just expected groups `forM_` \(groupname, tests) -> do @@ -146,33 +154,30 @@ main = do testProcessor = \case HeaderLine n : rest -> let normalLines = Data.Maybe.mapMaybe extractNormal rest - in - TestCase - { testName = n - , isPending = any isPendingLine rest - , content = Text.unlines normalLines - } + in TestCase + { testName = n + , isPending = any isPendingLine rest + , content = Text.unlines normalLines + } l -> - error - $ "first non-empty line must start with #test footest\n" - ++ show l + error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l - extractNormal _ = Nothing + extractNormal _ = Nothing isPendingLine PendingLine{} = True - isPendingLine _ = False + isPendingLine _ = False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#group" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" + | _ <- Parsec.try $ Parsec.string "#group" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof + , _ <- Parsec.eof ] , [ HeaderLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#test" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" + | _ <- Parsec.try $ Parsec.string "#test" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof + , _ <- Parsec.eof ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" @@ -192,17 +197,17 @@ main = do ] lineMapper :: Text -> InputLine lineMapper line = case Parsec.runParser specialLineParser () "" line of - Left _e -> NormalLine line - Right l -> l + Left _e -> NormalLine line + Right l -> l lineIsSpace :: InputLine -> Bool lineIsSpace CommentLine = True - lineIsSpace _ = False + lineIsSpace _ = False grouperG :: InputLine -> InputLine -> Bool grouperG _ GroupLine{} = False - grouperG _ _ = True + grouperG _ _ = True grouperT :: InputLine -> InputLine -> Bool grouperT _ HeaderLine{} = False - grouperT _ _ = True + grouperT _ _ = True -------------------- @@ -220,42 +225,43 @@ instance Show PPTextWrapper where show (PPTextWrapper t) = "\n" ++ Text.unpack t -- brittany-next-binding --columns 160 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } defaultTestConfig :: Config defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } - , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } + , _conf_preprocessor = _conf_preprocessor staticDefaultConfig + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config contextFreeTestConfig = defaultTestConfig { _conf_layout = (_conf_layout defaultTestConfig) - { _lconfig_indentPolicy = coerce IndentPolicyLeft - , _lconfig_alignmentLimit = coerce (1 :: Int) - , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } + { _lconfig_indentPolicy = coerce IndentPolicyLeft + , _lconfig_alignmentLimit = coerce (1 :: Int) + , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled + } } -- 2.30.2 From 8d7b46b9e916de843aed5aeda47ecb6e6c3658de Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 7 Nov 2021 13:01:54 +0000 Subject: [PATCH 455/478] Fix handling of comments --- data/10-tests.blt | 48 +++++++++++++++++++ .../Language/Haskell/Brittany/Internal.hs | 18 +++---- 2 files changed, 58 insertions(+), 8 deletions(-) diff --git a/data/10-tests.blt b/data/10-tests.blt index 75babb0..79d9a0a 100644 --- a/data/10-tests.blt +++ b/data/10-tests.blt @@ -1568,6 +1568,13 @@ type instance F Int = IO Int type family F a type instance F Int = IO Int -- x +#test type-instance-with-module-header + +{-# language TypeFamilies #-} +module M where +type family F a +type instance F Int = IO Int + #test newtype-instance-without-comment {-# language TypeFamilies #-} @@ -1580,6 +1587,13 @@ newtype instance F Int = N Int data family F a newtype instance F Int = N Int -- x +#test newtype-instance-with-module-header + +{-# language TypeFamilies #-} +module M where +data family F a +newtype instance F Int = N Int + #test data-instance-without-comment {-# language TypeFamilies #-} @@ -1592,6 +1606,13 @@ data instance F Int = D Int data family F a data instance F Int = D Int -- x +#test data-instance-with-module-header + +{-# language TypeFamilies #-} +module M where +data family F a +data instance F Int = D Int + #test instance-type-without-comment {-# language TypeFamilies #-} @@ -1608,6 +1629,15 @@ class C a where instance C Int where type F Int = IO Int -- x +#test instance-type-with-module-header + +{-# language TypeFamilies #-} +module M where +class C a where + type family F a +instance C Int where + type F Int = IO Int + #test instance-newtype-without-comment {-# language TypeFamilies #-} @@ -1624,6 +1654,15 @@ class C a where instance C Int where newtype F Int = N Int -- x +#test instance-newtype-with-module-header + +{-# language TypeFamilies #-} +module M where +class C a where + data family F a +instance C Int where + newtype F Int = N Int + #test instance-data-without-comment {-# language TypeFamilies #-} @@ -1640,6 +1679,15 @@ class C a where instance C Int where data F Int = D Int -- x +#test instance-data-with-module-header + +{-# language TypeFamilies #-} +module M where +class C a where + data family F a +instance C Int where + data F Int = D Int + ############################################################################### ############################################################################### ############################################################################### diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 71e885b..8d3e72e 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -400,7 +400,7 @@ parsePrintModuleTests conf filename input = do then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule - if all isErrorUnusedComment errs + if null errs then pure $ TextL.toStrict $ ltext else let @@ -413,11 +413,6 @@ parsePrintModuleTests conf filename input = do ErrorOutputCheck -> "Output is not syntactically valid." in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs -isErrorUnusedComment :: BrittanyError -> Bool -isErrorUnusedComment x = case x of - ErrorUnusedComment _ -> True - _ -> False - -- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally -- pure interface. @@ -461,7 +456,14 @@ toLocal conf anns m = do ppModule :: GenLocated SrcSpan HsModule -> PPM () ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do - let annKey = ExactPrint.mkAnnKey lmod + defaultAnns <- do + anns <- mAsk + let annKey = ExactPrint.mkAnnKey lmod + let annMap = Map.findWithDefault Map.empty annKey anns + let isEof = (== ExactPrint.AnnEofPos) + let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } + pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap + post <- ppPreamble lmod decls `forM_` \decl -> do let declAnnKey = ExactPrint.mkAnnKey decl @@ -472,7 +474,7 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf filteredAnns <- mAsk <&> \annMap -> - Map.union (Map.findWithDefault Map.empty annKey annMap) $ + Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap traceIfDumpConf "bridoc annotations filtered/transformed" -- 2.30.2 From ccd09ba40a82012a43bc81981a62d8408d1cc867 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 21 Nov 2021 13:28:15 +0000 Subject: [PATCH 456/478] Remove obsolete Stack configuration --- .gitignore | 2 -- README.md | 3 +-- stack.yaml | 13 --------- stack.yaml.lock | 72 ------------------------------------------------- 4 files changed, 1 insertion(+), 89 deletions(-) delete mode 100644 stack.yaml delete mode 100644 stack.yaml.lock diff --git a/.gitignore b/.gitignore index f04e47c..cdc020e 100644 --- a/.gitignore +++ b/.gitignore @@ -8,10 +8,8 @@ dist/ dist-newstyle/ local/ .cabal-sandbox/ -.stack-work/ cabal.sandbox.config cabal.project.local* cabal.project.freeze .ghc.environment.* result -.stack-work* diff --git a/README.md b/README.md index d88aed4..58119e9 100644 --- a/README.md +++ b/README.md @@ -65,8 +65,7 @@ log the size of the input, but _not_ the full input/output of requests.) ~~~~ If you use an lts that includes brittany this should just work; otherwise - you may want to clone the repo and try again (there are several stack.yamls - included). + you may want to clone the repo and try again. - via `cabal` diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 647404b..0000000 --- a/stack.yaml +++ /dev/null @@ -1,13 +0,0 @@ -system-ghc: true -allow-newer: true -resolver: nightly-2021-11-06 -extra-deps: - - aeson-2.0.1.0 - - butcher-1.3.3.2 - - Cabal-3.6.2.0 - - data-tree-print-0.1.0.2 - - multistate-0.8.0.3 - - parsec-3.1.14.0 - - text-1.2.5.0 - - git: https://github.com/mithrandi/czipwith - commit: b6245884ae83e00dd2b5261762549b37390179f8 diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index 087338e..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,72 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - hackage: aeson-2.0.1.0@sha256:ee0847af4d1fb9ece3f24f443d8d8406431c32688a57880314ac36617da937eb,6229 - pantry-tree: - size: 37910 - sha256: e7a9eec09f1ea56548b07c7e82b53bf32a974827ffc402d852c667b5f5d89efd - original: - hackage: aeson-2.0.1.0 -- completed: - hackage: butcher-1.3.3.2@sha256:0be5b914f648ec9c63cb88730d983602aef829a7c8c31343952e4642e6b52a84,3150 - pantry-tree: - size: 1197 - sha256: 96fe696234de07e4d9253d80ddf189f8cfaf2e262e977438343a6069677a39d2 - original: - hackage: butcher-1.3.3.2 -- completed: - hackage: Cabal-3.6.2.0@sha256:e2266e14758c1f799220fad7f0d4b0b4ec567d81b7ba3faea17ff76d4c31de95,12437 - pantry-tree: - size: 19757 - sha256: 6650e54cbbcda6d05c4d8b8094fa61e5ffbda15a798a354d2dad5b35dc3b2859 - original: - hackage: Cabal-3.6.2.0 -- completed: - hackage: data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620 - pantry-tree: - size: 272 - sha256: b8778eb1b16fddb91b2eed2b25f33a89d1e4f7a533160de4ccbf226f82456135 - original: - hackage: data-tree-print-0.1.0.2 -- completed: - hackage: multistate-0.8.0.3@sha256:49d600399f3a4bfd8c8ba2e924c6592e84915b63c52970818982baa274cd9ac3,3588 - pantry-tree: - size: 2143 - sha256: 73b47c11a753963b033b79209a66490013da35854dd1064b3633dd23c3fa5650 - original: - hackage: multistate-0.8.0.3 -- completed: - hackage: text-1.2.5.0@sha256:791f0f6c97ed96113f17ab520cf0efe1a3a4f883a8c85910a5660567c8241c40,7895 - pantry-tree: - size: 7395 - sha256: f41504ec5c04a3f3358ef104362f02fdef29cbce4e5e4e6dbd6b6db70c40d4bf - original: - hackage: text-1.2.5.0 -- completed: - hackage: parsec-3.1.14.0@sha256:72d5c57e6e126adaa781ab97b19dc76f68490c0a3d88f14038219994cabe94e1,4356 - pantry-tree: - size: 2574 - sha256: 495a86688c6e89faf38b8804cc4c9216709e9a6a93cf56c2f07d5bef83f09a17 - original: - hackage: parsec-3.1.14.0 -- completed: - name: czipwith - version: 1.0.1.3 - git: https://github.com/mithrandi/czipwith - pantry-tree: - size: 964 - sha256: 239a37e26558e6272c07dc280ee07a83407ed6b86000047ddb979726c23818c4 - commit: b6245884ae83e00dd2b5261762549b37390179f8 - original: - git: https://github.com/mithrandi/czipwith - commit: b6245884ae83e00dd2b5261762549b37390179f8 -snapshots: -- completed: - size: 594850 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/11/6.yaml - sha256: b5d7eef8b8b34d08a9604179e2594a9a5025d872146556b51f9d2f7bfead834b - original: nightly-2021-11-06 -- 2.30.2 From 8fadac8b2ead98714a15db0958401d83b826dcd9 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 21 Nov 2021 13:44:06 +0000 Subject: [PATCH 457/478] Format imports --- .vscode/settings.json | 2 +- brittany.yaml | 4 + source/library/Language/Haskell/Brittany.hs | 14 +- .../Language/Haskell/Brittany/Internal.hs | 86 ++- .../Haskell/Brittany/Internal/Backend.hs | 22 +- .../Haskell/Brittany/Internal/BackendUtils.hs | 22 +- .../Haskell/Brittany/Internal/Config.hs | 40 +- .../Haskell/Brittany/Internal/Config/Types.hs | 21 +- .../Internal/Config/Types/Instances.hs | 8 +- .../Brittany/Internal/ExactPrintUtils.hs | 47 +- .../Brittany/Internal/LayouterBasics.hs | 47 +- .../Brittany/Internal/Layouters/DataDecl.hs | 23 +- .../Brittany/Internal/Layouters/Decl.hs | 56 +- .../Brittany/Internal/Layouters/Expr.hs | 35 +- .../Brittany/Internal/Layouters/Expr.hs-boot | 9 +- .../Haskell/Brittany/Internal/Layouters/IE.hs | 28 +- .../Brittany/Internal/Layouters/Import.hs | 24 +- .../Brittany/Internal/Layouters/Module.hs | 29 +- .../Brittany/Internal/Layouters/Pattern.hs | 23 +- .../Brittany/Internal/Layouters/Stmt.hs | 24 +- .../Brittany/Internal/Layouters/Stmt.hs-boot | 9 +- .../Brittany/Internal/Layouters/Type.hs | 28 +- .../Haskell/Brittany/Internal/Obfuscation.hs | 11 +- .../Haskell/Brittany/Internal/Prelude.hs | 538 +++++++----------- .../Haskell/Brittany/Internal/PreludeUtils.hs | 15 +- .../Brittany/Internal/Transformations/Alt.hs | 19 +- .../Internal/Transformations/Columns.hs | 10 +- .../Internal/Transformations/Floating.hs | 12 +- .../Internal/Transformations/Indent.hs | 10 +- .../Brittany/Internal/Transformations/Par.hs | 7 +- .../Haskell/Brittany/Internal/Types.hs | 32 +- .../Haskell/Brittany/Internal/Utils.hs | 39 +- .../library/Language/Haskell/Brittany/Main.hs | 67 +-- source/test-suite/Main.hs | 37 +- 34 files changed, 522 insertions(+), 876 deletions(-) create mode 100644 brittany.yaml diff --git a/.vscode/settings.json b/.vscode/settings.json index 0050442..8b52b40 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -1,5 +1,5 @@ { - "purple-yolk.brittany.command": "false", + "purple-yolk.brittany.command": "cabal exec -- brittany --write-mode inplace", "purple-yolk.ghci.command": "cabal repl --repl-options -ddump-json", "purple-yolk.hlint.command": "false", "purple-yolk.hlint.onSave": false diff --git a/brittany.yaml b/brittany.yaml new file mode 100644 index 0000000..b85e4ad --- /dev/null +++ b/brittany.yaml @@ -0,0 +1,4 @@ +conf_layout: + lconfig_columnAlignMode: + tag: ColumnAlignModeDisabled + lconfig_indentPolicy: IndentPolicyLeft diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs index 8c225c6..a2726c8 100644 --- a/source/library/Language/Haskell/Brittany.hs +++ b/source/library/Language/Haskell/Brittany.hs @@ -16,13 +16,9 @@ module Language.Haskell.Brittany , CForwardOptions(..) , CPreProcessorConfig(..) , BrittanyError(..) - ) -where + ) where - - - -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 8d3e72e..b8940b1 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -12,66 +12,52 @@ module Language.Haskell.Brittany.Internal , parseModuleFromString , extractCommentConfigs , getTopLevelDeclNameMap - ) -where + ) where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Control.Monad.Trans.Except import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Char (isSpace) +import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TextL -import qualified GHC.OldList as List - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers - -import Control.Monad.Trans.Except -import Data.HList.HList +import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Yaml -import Data.CZipWith -import qualified UI.Butcher.Monadic as Butcher - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.LayouterBasics - -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Indent - -import qualified GHC - hiding ( parseModule ) -import GHC.Parser.Annotation ( AnnKeywordId(..) ) -import GHC ( GenLocated(L) - ) -import GHC.Types.SrcLoc ( SrcSpan ) -import GHC.Hs -import GHC.Data.Bag -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Data.Char ( isSpace ) +import qualified GHC hiding (parseModule) +import GHC (GenLocated(L)) +import GHC.Data.Bag +import qualified GHC.Driver.Session as GHC +import GHC.Hs +import qualified GHC.LanguageExtensions.Type as GHC +import qualified GHC.OldList as List +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.SrcLoc (SrcSpan) +import Language.Haskell.Brittany.Internal.Backend +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Transformations.Alt +import Language.Haskell.Brittany.Internal.Transformations.Columns +import Language.Haskell.Brittany.Internal.Transformations.Floating +import Language.Haskell.Brittany.Internal.Transformations.Indent +import Language.Haskell.Brittany.Internal.Transformations.Par +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified UI.Butcher.Monadic as Butcher diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs index 142fe2f..6cfbaf3 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -6,10 +6,6 @@ module Language.Haskell.Brittany.Internal.Backend where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.State.Strict as StateS import qualified Data.Either as Either import qualified Data.Foldable as Foldable @@ -21,20 +17,18 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.OldList as List - +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - - -import qualified Data.Text.Lazy.Builder as Text.Builder - type ColIndex = Int diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index 6c34ea9..919a323 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -3,28 +3,22 @@ module Language.Haskell.Brittany.Internal.BackendUtils where - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Either import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey - , Annotation - ) - import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (Located) +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.Brittany.Internal.Utils - -import GHC ( Located ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs index 66d6d7f..08d0fd4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -3,36 +3,26 @@ module Language.Haskell.Brittany.Internal.Config where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Bool as Bool import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Coerce (coerce) +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Semigroup as Semigroup -import qualified GHC.OldList as List -import qualified System.Directory -import qualified System.IO - import qualified Data.Yaml -import Data.CZipWith - -import UI.Butcher.Monadic - -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 ( coerce - ) -import qualified Data.List.NonEmpty as NonEmpty - -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config.Types.Instances () +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Utils +import qualified System.Console.CmdArgs.Explicit as CmdArgs +import qualified System.Directory +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import UI.Butcher.Monadic -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 929ac90..bb7148d 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -7,22 +7,15 @@ module Language.Haskell.Brittany.Internal.Config.Types where - - +import Data.CZipWith +import Data.Coerce (Coercible, coerce) +import Data.Data (Data) +import qualified Data.Semigroup as Semigroup +import Data.Semigroup (Last) +import Data.Semigroup.Generic +import GHC.Generics import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils () -import qualified Data.Semigroup as Semigroup - -import GHC.Generics - -import Data.Data ( Data ) - -import Data.Coerce ( Coercible, coerce ) - -import Data.Semigroup.Generic -import Data.Semigroup ( Last ) - -import Data.CZipWith diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 2c0c78f..0c25537 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -18,15 +18,11 @@ module Language.Haskell.Brittany.Internal.Config.Types.Instances where - - -import Language.Haskell.Brittany.Internal.Prelude - -import Data.Yaml import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson - +import Data.Yaml import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 46e1b6a..28a40b0 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -7,45 +7,34 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Control.Exception import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.Data import qualified Data.Foldable as Foldable +import qualified Data.Generics as SYB +import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Set as Set -import qualified System.IO - -import Language.Haskell.Brittany.Internal.Config.Types -import Data.Data -import Data.HList.HList - -import GHC ( GenLocated(L) ) -import qualified GHC.Driver.Session as GHC +import GHC (GenLocated(L)) import qualified GHC hiding (parseModule) -import qualified GHC.Types.SrcLoc as GHC +import GHC.Data.Bag import qualified GHC.Driver.CmdLine as GHC - -import GHC.Hs -import GHC.Data.Bag - -import GHC.Types.SrcLoc ( SrcSpan, Located ) - - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint - -import qualified Data.Generics as SYB - -import Control.Exception --- import Data.Generics.Schemes +import qualified GHC.Driver.Session as GHC +import GHC.Hs +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.SrcLoc (Located, SrcSpan) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified System.IO diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 422c7be..4606eac 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -6,48 +6,37 @@ module Language.Haskell.Brittany.Internal.LayouterBasics where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Writer.Strict as Writer +import qualified Data.Char as Char +import Data.Data import qualified Data.Map as Map import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import DataTreePrint +import GHC (GenLocated(L), Located, moduleName, moduleNameString) import qualified GHC.OldList as List - -import qualified Control.Monad.Writer.Strict as Writer - +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.Name (getOccString) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName(..)) +import qualified GHC.Types.SrcLoc as GHC +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import GHC.Types.Name.Reader ( RdrName(..) ) -import GHC ( Located, GenLocated(L), moduleName, moduleNameString ) -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.Name.Occurrence ( occNameString ) -import GHC.Types.Name ( getOccString ) -import GHC.Parser.Annotation ( AnnKeywordId(..) ) - -import Data.Data - -import qualified Data.Char as Char - -import DataTreePrint - processDefault diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index acbe186..dc7d022 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -3,24 +3,19 @@ module Language.Haskell.Brittany.Internal.Layouters.DataDecl where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( Located, GenLocated(L) ) +import GHC (GenLocated(L), Located) import qualified GHC -import GHC.Hs - -import Language.Haskell.Brittany.Internal.Layouters.Type +import GHC.Hs +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index a96ae47..db58abc 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -5,46 +5,38 @@ module Language.Haskell.Brittany.Internal.Layouters.Decl where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Foldable import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Layouters.Type - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint -import Language.Haskell.Brittany.Internal.ExactPrintUtils - -import GHC ( GenLocated(L) - , AnnKeywordId(..) - ) -import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc ) +import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC.Data.Bag (bagToList, emptyBag) import qualified GHC.Data.FastString as FastString -import GHC.Hs -import GHC.Types.Basic ( InlinePragma(..) - , Activation(..) - , InlineSpec(..) - , RuleMatchInfo(..) - , LexicalFixity(..) - ) -import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) - +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic + ( Activation(..) + , InlinePragma(..) + , InlineSpec(..) + , LexicalFixity(..) + , RuleMatchInfo(..) + ) +import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Pattern import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.DataDecl - -import GHC.Data.Bag ( bagToList, emptyBag ) +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 344454c..9a13adf 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -4,31 +4,26 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( GenLocated(L), SrcSpan, AnnKeywordId(..), RdrName(..) ) -import GHC.Hs -import GHC.Types.Name +import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) import qualified GHC.Data.FastString as FastString -import GHC.Types.Basic - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Types.Name +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 8fb094b..4f913c3 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -2,13 +2,8 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where - - -import Language.Haskell.Brittany.Internal.Prelude - -import Language.Haskell.Brittany.Internal.Types - -import GHC.Hs +import GHC.Hs +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 39b7a49..78c56e4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -4,24 +4,22 @@ module Language.Haskell.Brittany.Internal.Layouters.IE where -import Language.Haskell.Brittany.Internal.Prelude import qualified Data.List.Extra import qualified Data.Text as Text +import GHC + ( AnnKeywordId(..) + , GenLocated(L) + , Located + , ModuleName + , moduleNameString + , unLoc + ) +import GHC.Hs import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import GHC ( unLoc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - , Located - , ModuleName - ) -import GHC.Hs - -import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 1b19145..d8ff3ff 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -2,24 +2,18 @@ module Language.Haskell.Brittany.Internal.Layouters.Import where -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( unLoc - , GenLocated(L) - , moduleNameString - , Located - ) -import GHC.Hs -import GHC.Types.Basic +import GHC (GenLocated(L), Located, moduleNameString, unLoc) +import GHC.Hs +import GHC.Types.Basic import GHC.Unit.Types (IsBootInterface(..)) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 52c2cd1..73090ce 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -3,27 +3,22 @@ module Language.Haskell.Brittany.Internal.Layouters.Module where -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) +import GHC.Hs import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..)) -import GHC.Hs -import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types - ( DeltaPos(..) - , deltaRow - , commentContents - ) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types + (DeltaPos(..), commentContents, deltaRow) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 4b99bca..fd4025a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -3,26 +3,19 @@ module Language.Haskell.Brittany.Internal.Layouters.Pattern where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import qualified Data.Text as Text +import GHC (GenLocated(L), ol_val) +import GHC.Hs import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics - -import GHC ( GenLocated(L) - , ol_val - ) -import GHC.Hs -import GHC.Types.Basic - +import GHC.Types.Basic +import Language.Haskell.Brittany.Internal.LayouterBasics import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 95f7273..7f297fe 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -4,24 +4,18 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Config.Types - -import GHC ( GenLocated(L) - ) -import GHC.Hs - -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Decl +import GHC (GenLocated(L)) +import GHC.Hs +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 02b388c..6cfd5c8 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -2,13 +2,8 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where - - -import Language.Haskell.Brittany.Internal.Prelude - -import Language.Haskell.Brittany.Internal.Types - -import GHC.Hs +import GHC.Hs +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index ed0dd26..208f6b4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -3,26 +3,18 @@ module Language.Haskell.Brittany.Internal.Layouters.Type where - - +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Utils.Outputable (ftext, showSDocUnsafe) +import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Data.Text as Text -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Utils - ( splitFirstLast - , FirstLastView(..) - ) - -import GHC ( GenLocated(L) - , AnnKeywordId (..) - ) -import GHC.Hs -import GHC.Utils.Outputable ( ftext, showSDocUnsafe ) -import GHC.Types.Basic +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + (FirstLastView(..), splitFirstLast) diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs index 29dc13c..8b09fa1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -2,17 +2,14 @@ module Language.Haskell.Brittany.Internal.Obfuscation where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Data.Char import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified GHC.OldList as List - -import Data.Char -import System.Random +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import System.Random diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs index 87a0c0a..8198533 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,346 +1,194 @@ -module Language.Haskell.Brittany.Internal.Prelude ( module E ) where +module Language.Haskell.Brittany.Internal.Prelude + ( module E + ) where - - --- rather project-specific stuff: ---------------------------------- -import GHC.Hs.Extension as E ( GhcPs ) - -import GHC.Types.Name.Reader as E ( RdrName ) - - --- more general: ----------------- - -import Data.Functor.Identity as E ( Identity(..) ) -import Control.Concurrent.Chan as E ( Chan ) -import Control.Concurrent.MVar as E ( MVar - , newEmptyMVar - , newMVar - , putMVar - , readMVar - , takeMVar - , swapMVar - ) -import Data.Int as E ( Int ) -import Data.Word as E ( Word - , Word32 - ) -import Prelude as E ( Integer - , Float - , Double - , undefined - , Eq (..) - , Ord (..) - , Enum (..) - , Bounded (..) - , (<$>) - , (.) - , ($) - , ($!) - , Num (..) - , Integral (..) - , Fractional (..) - , Floating (..) - , RealFrac (..) - , RealFloat (..) - , fromIntegral - , error - , foldr - , foldl - , foldr1 - , id - , map - , subtract - , putStrLn - , putStr - , Show (..) - , print - , fst - , snd - , (++) - , not - , (&&) - , (||) - , curry - , uncurry - , flip - , const - , seq - , reverse - , otherwise - , traverse - , realToFrac - , or - , and - , head - , any - , (^) - , Foldable - , Traversable - ) -import Control.Monad.ST as E ( ST ) -import Data.Bool as E ( Bool(..) ) -import Data.Char as E ( Char - , ord - , chr - ) -import Data.Either as E ( Either(..) - , either - ) -import Data.IORef as E ( IORef ) -import Data.Maybe as E ( Maybe(..) - , fromMaybe - , maybe - , listToMaybe - , maybeToList - , catMaybes - ) -import Data.Monoid as E ( Endo(..) - , All(..) - , Any(..) - , Sum(..) - , Product(..) - , Alt(..) - , mconcat - , Monoid (..) - ) -import Data.Ord as E ( Ordering(..) - , Down(..) - , comparing - ) -import Data.Ratio as E ( Ratio - , Rational - , (%) - , numerator - , denominator - ) -import Data.String as E ( String ) -import Data.Void as E ( Void ) -import System.IO as E ( IO - , hFlush - , stdout - ) -import Data.Proxy as E ( Proxy(..) ) -import Data.Sequence as E ( Seq ) - -import Data.Map as E ( Map ) -import Data.Set as E ( Set ) - -import Data.Text as E ( Text ) - -import Data.Function as E ( fix - , (&) - ) - -import Data.Foldable as E ( foldl' - , foldr' - , fold - , asum - ) - -import Data.List as E ( partition - , null - , elem - , notElem - , minimum - , maximum - , length - , all - , take - , drop - , find - , sum - , zip - , zip3 - , zipWith - , repeat - , replicate - , iterate - , nub - , filter - , intersperse - , intercalate - , isSuffixOf - , isPrefixOf - , dropWhile - , takeWhile - , unzip - , break - , transpose - , sortBy - , mapAccumL - , mapAccumR - , uncons - ) - -import Data.List.NonEmpty as E ( NonEmpty(..) - , nonEmpty - ) - -import Data.Tuple as E ( swap - ) - -import Text.Read as E ( readMaybe - ) - -import Control.Monad as E ( Functor (..) - , Monad (..) - , MonadPlus (..) - , mapM - , mapM_ - , forM - , forM_ - , sequence - , sequence_ - , (=<<) - , (>=>) - , (<=<) - , forever - , void - , join - , replicateM - , replicateM_ - , guard - , when - , unless - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , filterM - , (<$!>) - ) - -import Control.Applicative as E ( Applicative (..) - , Alternative (..) - ) - -import Foreign.Storable as E ( Storable ) -import GHC.Exts as E ( Constraint ) - -import Control.Concurrent as E ( threadDelay - , forkIO - , forkOS - ) - -import Control.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.Bifunctor as E ( bimap ) -import Data.Functor as E ( ($>) ) -import Data.Semigroup as E ( (<>) - , Semigroup(..) - ) - -import Data.Typeable as E ( Typeable - ) - -import Control.Arrow as E ( first - , second - , (***) - , (&&&) - , (>>>) - , (<<<) - ) - -import Data.Version as E ( showVersion - ) - -import Data.List.Extra as E ( nubOrd - , stripSuffix - ) -import Control.Monad.Extra as E ( whenM - , unlessM - , ifM - , notM - , orM - , andM - , anyM - , allM - ) - -import Data.Tree as E ( Tree(..) - ) - -import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) - -- , MultiRWSTNull - -- , MultiRWS - -- , - MonadMultiReader(..) - , MonadMultiWriter(..) - , MonadMultiState(..) - , mGet - -- , runMultiRWST - -- , runMultiRWSTASW - -- , runMultiRWSTW - -- , runMultiRWSTAW - -- , runMultiRWSTSW - -- , runMultiRWSTNil - -- , runMultiRWSTNil_ - -- , withMultiReader - -- , withMultiReader_ - -- , withMultiReaders - -- , withMultiReaders_ - -- , withMultiWriter - -- , withMultiWriterAW - -- , withMultiWriterWA - -- , withMultiWriterW - -- , withMultiWriters - -- , withMultiWritersAW - -- , withMultiWritersWA - -- , withMultiWritersW - -- , withMultiState - -- , withMultiStateAS - -- , withMultiStateSA - -- , withMultiStateA - -- , withMultiStateS - -- , withMultiState_ - -- , withMultiStates - -- , withMultiStatesAS - -- , withMultiStatesSA - -- , withMultiStatesA - -- , withMultiStatesS - -- , withMultiStates_ - -- , inflateReader - -- , inflateMultiReader - -- , inflateWriter - -- , inflateMultiWriter - -- , inflateState - -- , inflateMultiState - -- , mapMultiRWST - -- , mGetRawR - -- , mGetRawW - -- , mGetRawS - -- , mPutRawR - -- , mPutRawW - -- , mPutRawS - ) - -import Control.Monad.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 - ) +import Control.Applicative as E (Alternative(..), Applicative(..)) +import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) +import Control.Concurrent as E (forkIO, forkOS, threadDelay) +import Control.Concurrent.Chan as E (Chan) +import Control.Concurrent.MVar as E + (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) +import Control.Exception as E (assert, bracket, evaluate) +import Control.Monad as E + ( (<$!>) + , (<=<) + , (=<<) + , (>=>) + , Functor(..) + , Monad(..) + , MonadPlus(..) + , filterM + , forM + , forM_ + , forever + , guard + , join + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , mapM + , mapM_ + , replicateM + , replicateM_ + , sequence + , sequence_ + , unless + , void + , when + ) +import Control.Monad.Extra as E + (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) +import Control.Monad.IO.Class as E (MonadIO(..)) +import Control.Monad.ST as E (ST) +import Control.Monad.Trans.Class as E (lift) +import Control.Monad.Trans.Maybe as E (MaybeT(..)) +import Control.Monad.Trans.MultiRWS as E + (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) +import Data.Bifunctor as E (bimap) +import Data.Bool as E (Bool(..)) +import Data.Char as E (Char, chr, ord) +import Data.Data as E (toConstr) +import Data.Either as E (Either(..), either) +import Data.Foldable as E (asum, fold, foldl', foldr') +import Data.Function as E ((&), fix) +import Data.Functor as E (($>)) +import Data.Functor.Identity as E (Identity(..)) +import Data.IORef as E (IORef) +import Data.Int as E (Int) +import Data.List as E + ( all + , break + , drop + , dropWhile + , elem + , filter + , find + , intercalate + , intersperse + , isPrefixOf + , isSuffixOf + , iterate + , length + , mapAccumL + , mapAccumR + , maximum + , minimum + , notElem + , nub + , null + , partition + , repeat + , replicate + , sortBy + , sum + , take + , takeWhile + , transpose + , uncons + , unzip + , zip + , zip3 + , zipWith + ) +import Data.List.Extra as E (nubOrd, stripSuffix) +import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) +import Data.Map as E (Map) +import Data.Maybe as E + (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) +import Data.Monoid as E + ( All(..) + , Alt(..) + , Any(..) + , Endo(..) + , Monoid(..) + , Product(..) + , Sum(..) + , mconcat + ) +import Data.Ord as E (Down(..), Ordering(..), comparing) +import Data.Proxy as E (Proxy(..)) +import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) +import Data.Semigroup as E ((<>), Semigroup(..)) +import Data.Sequence as E (Seq) +import Data.Set as E (Set) +import Data.String as E (String) +import Data.Text as E (Text) +import Data.Tree as E (Tree(..)) +import Data.Tuple as E (swap) +import Data.Typeable as E (Typeable) +import Data.Version as E (showVersion) +import Data.Void as E (Void) +import Data.Word as E (Word, Word32) +import Debug.Trace as E + ( trace + , traceIO + , traceId + , traceM + , traceShow + , traceShowId + , traceShowM + , traceStack + ) +import Foreign.ForeignPtr as E (ForeignPtr) +import Foreign.Storable as E (Storable) +import GHC.Exts as E (Constraint) +import GHC.Hs.Extension as E (GhcPs) +import GHC.Types.Name.Reader as E (RdrName) +import Prelude as E + ( ($) + , ($!) + , (&&) + , (++) + , (.) + , (<$>) + , Bounded(..) + , Double + , Enum(..) + , Eq(..) + , Float + , Floating(..) + , Foldable + , Fractional(..) + , Integer + , Integral(..) + , Num(..) + , Ord(..) + , RealFloat(..) + , RealFrac(..) + , Show(..) + , Traversable + , (^) + , and + , any + , const + , curry + , error + , flip + , foldl + , foldr + , foldr1 + , fromIntegral + , fst + , head + , id + , map + , not + , or + , otherwise + , print + , putStr + , putStrLn + , realToFrac + , reverse + , seq + , snd + , subtract + , traverse + , uncurry + , undefined + , (||) + ) +import System.IO as E (IO, hFlush, stdout) +import Text.Read as E (readMaybe) diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs index cfaed43..d2527e9 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -1,19 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} + module Language.Haskell.Brittany.Internal.PreludeUtils where - - -import Prelude +import Control.Applicative +import Control.DeepSeq (NFData, force) +import Control.Exception.Base (evaluate) +import Control.Monad import qualified Data.Strict.Maybe as Strict import Debug.Trace -import Control.Monad +import Prelude import System.IO -import Control.DeepSeq ( NFData, force ) -import Control.Exception.Base ( evaluate ) - -import Control.Applicative - instance Applicative Strict.Maybe where diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index ca79995..0e5b85f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -9,23 +9,18 @@ module Language.Haskell.Brittany.Internal.Transformations.Alt where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Control.Monad.Memo as Memo import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.HList.ContainsType import qualified Data.List.Extra import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified GHC.OldList as List - -import Data.HList.ContainsType - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Control.Monad.Memo as Memo +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 89a2c6f..3dcdb46 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -3,14 +3,10 @@ module Language.Haskell.Brittany.Internal.Transformations.Columns where - - -import Language.Haskell.Brittany.Internal.Prelude -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types - import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 0231306..5ba0ce5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -3,16 +3,12 @@ module Language.Haskell.Brittany.Internal.Transformations.Floating where - - +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 7f7d7e5..648e7c7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -3,14 +3,10 @@ module Language.Haskell.Brittany.Internal.Transformations.Indent where - - -import Language.Haskell.Brittany.Internal.Prelude -import qualified GHC.OldList as List - -import Language.Haskell.Brittany.Internal.Types - import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 305ee08..2d1abf1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -3,12 +3,9 @@ module Language.Haskell.Brittany.Internal.Transformations.Par where - - import Language.Haskell.Brittany.Internal.Prelude - -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 76b7735..6a2c8af 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -12,30 +12,20 @@ module Language.Haskell.Brittany.Internal.Types where - - -import Language.Haskell.Brittany.Internal.Prelude import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data -import qualified Data.Strict.Maybe as Strict -import qualified Safe - -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - -import qualified Data.Text.Lazy.Builder as Text.Builder - -import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan ) - -import Language.Haskell.GHC.ExactPrint ( AnnKey ) -import Language.Haskell.GHC.ExactPrint.Types ( Anns ) - -import Language.Haskell.Brittany.Internal.Config.Types - -import Data.Generics.Uniplate.Direct as Uniplate - +import Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Kind as Kind - +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint (AnnKey) +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Types (Anns) +import qualified Safe data PerItemConfig = PerItemConfig diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index a12f7ea..38f9123 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -7,38 +7,29 @@ module Language.Haskell.Brittany.Internal.Utils where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified Data.ByteString as B import qualified Data.Coerce +import Data.Data +import Data.Generics.Aliases +import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq +import DataTreePrint +import qualified GHC.Data.FastString as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Hs.Extension as HsExtension import qualified GHC.OldList as List - +import GHC.Types.Name.Occurrence as OccName (occNameString) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Outputable as GHC +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - -import Data.Data -import Data.Generics.Aliases - import qualified Text.PrettyPrint as PP -import qualified GHC.Utils.Outputable as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Data.FastString as GHC -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.Name.Occurrence as OccName ( occNameString ) -import qualified Data.ByteString as B - -import DataTreePrint - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types - -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.Hs.Extension as HsExtension - parDoc :: String -> PP.Doc diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index 87ebe66..c32f1f7 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -4,56 +4,41 @@ module Language.Haskell.Brittany.Main where - - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Control.Monad (zipWithM) import qualified Control.Monad.Trans.Except as ExceptT +import Data.CZipWith import qualified Data.Either import qualified Data.List.Extra +import qualified Data.Monoid import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy as TextL +import DataTreePrint +import GHC (GenLocated(L)) +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List -import qualified System.IO - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Data.Monoid - -import GHC ( GenLocated(L) ) -import GHC.Utils.Outputable ( Outputable(..) - , showSDocUnsafe - ) - -import Text.Read ( Read(..) ) -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec - -import Control.Monad ( zipWithM ) -import Data.CZipWith - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Obfuscation - -import qualified Text.PrettyPrint as PP - -import DataTreePrint -import UI.Butcher.Monadic - +import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Obfuscation +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import Paths_brittany +import qualified System.Directory as Directory import qualified System.Exit -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Paths_brittany +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.PrettyPrint as PP +import Text.Read (Read(..)) +import UI.Butcher.Monadic diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 774088f..36e79ef 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -2,35 +2,24 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE ScopedTypeVariables #-} -import Language.Haskell.Brittany.Internal.Prelude +import Data.Coerce (coerce) +import Data.List (groupBy) import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO import qualified GHC.OldList as List -import qualified System.Directory - -import Test.Hspec - -import qualified Text.Parsec as Parsec -import Text.Parsec.Text ( Parser ) - -import Data.List ( groupBy ) - -import Language.Haskell.Brittany.Internal - -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config - -import Data.Coerce ( coerce ) - -import qualified Data.Text.IO as Text.IO -import System.FilePath ( () ) - -import System.Timeout ( timeout ) - - - +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils +import qualified System.Directory +import System.FilePath (()) +import System.Timeout (timeout) +import Test.Hspec +import qualified Text.Parsec as Parsec +import Text.Parsec.Text (Parser) hush :: Either a b -> Maybe b hush = either (const Nothing) Just -- 2.30.2 From fa8365a7fa9372043d5a1018f2f7669ce3853edd Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 21 Nov 2021 13:53:46 +0000 Subject: [PATCH 458/478] Set up release job --- .github/workflows/ci.yaml | 54 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e3b50a2..a3ca188 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -6,6 +6,9 @@ on: push: branches: - main + release: + types: + - created jobs: build: strategy: @@ -47,3 +50,54 @@ jobs: with: path: artifact name: brittany-${{ github.sha }} + + release: + needs: ci + if: github.event_name == 'release' + runs-on: ubuntu-20.04 + steps: + + - uses: actions/checkout@v2 + + - uses: actions/download-artifact@v2 + with: + name: brittany-${{ github.sha }} + path: artifact + + - uses: actions/upload-release-asset@v1 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + asset_content_type: application/octet-stream + asset_name: brittany-${{ github.event.release.tag_name }}-ubuntu + asset_path: artifact/ubuntu-20.04/brittany + upload_url: ${{ github.event.release.upload_url }} + + - uses: actions/upload-release-asset@v1 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + asset_content_type: application/octet-stream + asset_name: brittany-${{ github.event.release.tag_name }}-macos + asset_path: artifact/macos-11/brittany + upload_url: ${{ github.event.release.upload_url }} + + - uses: actions/upload-release-asset@v1 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + asset_content_type: application/octet-stream + asset_name: brittany-${{ github.event.release.tag_name }}-windows.exe + asset_path: artifact/windows-2019/brittany.exe + upload_url: ${{ github.event.release.upload_url }} + + - uses: actions/upload-release-asset@v1 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + asset_content_type: application/gzip + asset_name: brittany-${{ github.event.release.tag_name }}.tar.gz + asset_path: artifact/ubuntu-20.04/brittany-${{ github.event.release.tag_name }}.tar.gz + upload_url: ${{ github.event.release.upload_url }} + + - run: cabal upload --publish --username '${{ secrets.HACKAGE_USERNAME }}' --password '${{ secrets.HACKAGE_PASSWORD }}' artifact/ubuntu-20.04/brittany-${{ github.event.release.tag_name }}.tar.gz -- 2.30.2 From cdc8405b10350c2eb495ed8ee3af5fe03a47c9cb Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 21 Nov 2021 13:59:35 +0000 Subject: [PATCH 459/478] Remove mentions of GHC 8.x --- README.md | 2 +- data/15-regressions.blt | 3 --- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/README.md b/README.md index 58119e9..76ad1bf 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ log the size of the input, but _not_ the full input/output of requests.) # Other usage notes -- Supports GHC versions `8.6`, `8.8`, `8.10`. +- Supports GHC version `9.0.x`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. diff --git a/data/15-regressions.blt b/data/15-regressions.blt index e288114..df2dada 100644 --- a/data/15-regressions.blt +++ b/data/15-regressions.blt @@ -497,15 +497,12 @@ v = A { .. } where b = 2 v = A { a = 1, b = 2, c = 3 } #test issue 63 a -#pending fix does not work on 8.0.2 test :: Proxy 'Int #test issue 63 b -#pending fix does not work on 8.0.2 test :: Proxy '[ 'True] #test issue 63 c -#pending fix does not work on 8.0.2 test :: Proxy '[Bool] #test issue 64 -- 2.30.2 From b8532ca631b11aa89469f6661b15e75d24dd83d4 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 21 Nov 2021 14:05:37 +0000 Subject: [PATCH 460/478] Fix release job dependency --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index a3ca188..11b88e8 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -52,7 +52,7 @@ jobs: name: brittany-${{ github.sha }} release: - needs: ci + needs: build if: github.event_name == 'release' runs-on: ubuntu-20.04 steps: -- 2.30.2 From ab59e9acc3069551ac4132321b285d000f5f5691 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 21 Nov 2021 22:58:07 +0000 Subject: [PATCH 461/478] Parse modules "purely", without ghc-paths --- brittany.cabal | 2 + data/10-tests.blt | 3 + .../Language/Haskell/Brittany/Internal.hs | 12 +- .../Brittany/Internal/ExactPrintUtils.hs | 73 +-- .../Haskell/Brittany/Internal/ParseModule.hs | 508 ++++++++++++++++++ 5 files changed, 525 insertions(+), 73 deletions(-) create mode 100644 source/library/Language/Haskell/Brittany/Internal/ParseModule.hs diff --git a/brittany.cabal b/brittany.cabal index 79d5b8b..84db13f 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -50,6 +50,7 @@ common library , extra ^>= 1.7.10 , filepath ^>= 1.4.2 , ghc ^>= 9.0.1 + , ghc-boot ^>= 9.0.1 , ghc-boot-th ^>= 9.0.1 , ghc-exactprint ^>= 0.6.4 , monad-memo ^>= 0.5.3 @@ -118,6 +119,7 @@ library Language.Haskell.Brittany.Internal.Layouters.Stmt Language.Haskell.Brittany.Internal.Layouters.Type Language.Haskell.Brittany.Internal.Obfuscation + Language.Haskell.Brittany.Internal.ParseModule Language.Haskell.Brittany.Internal.Prelude Language.Haskell.Brittany.Internal.PreludeUtils Language.Haskell.Brittany.Internal.Transformations.Alt diff --git a/data/10-tests.blt b/data/10-tests.blt index 79d9a0a..311c911 100644 --- a/data/10-tests.blt +++ b/data/10-tests.blt @@ -363,6 +363,7 @@ data MyRecord = MyConstructor } #test record with DataTypeContexts +#pending data type contexts are deprecated in ghc 9.0 {-# LANGUAGE DatatypeContexts #-} data ( LooooooooooooooooooooongConstraint a @@ -1349,6 +1350,8 @@ type MySynonym3 b a #test synonym-with-kind-sig +{-# LANGUAGE StarIsType #-} + type MySynonym (a :: * -> *) = MySynonym a b -> MySynonym a b diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index b8940b1..456ef4a 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -30,7 +30,6 @@ import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Yaml import qualified GHC hiding (parseModule) import GHC (GenLocated(L)) -import GHC.Data.Bag import qualified GHC.Driver.Session as GHC import GHC.Hs import qualified GHC.LanguageExtensions.Type as GHC @@ -55,7 +54,6 @@ import Language.Haskell.Brittany.Internal.Transformations.Par import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified UI.Butcher.Monadic as Butcher @@ -368,10 +366,14 @@ pPrintModuleAndCheck conf inlineConf anns parsedModule = do parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input - parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr + parseResult <- parseModuleFromString + (conf & _conf_forward & _options_ghc & runIdentity) + filename + (const . pure $ Right ()) + inputStr case parseResult of - Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) - Right (anns, parsedModule) -> runExceptT $ do + Left err -> return $ Left err + Right (anns, parsedModule, _) -> runExceptT $ do (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of Left err -> throwE $ "error in inline config: " ++ show err diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 28a40b0..b93fbbc 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -7,9 +7,7 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils where -import Control.Exception import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import Data.Data import qualified Data.Foldable as Foldable @@ -21,18 +19,15 @@ import qualified Data.Sequence as Seq import qualified Data.Set as Set import GHC (GenLocated(L)) import qualified GHC hiding (parseModule) -import GHC.Data.Bag import qualified GHC.Driver.CmdLine as GHC -import qualified GHC.Driver.Session as GHC import GHC.Hs import qualified GHC.Types.SrcLoc as GHC import GHC.Types.SrcLoc (Located, SrcSpan) import Language.Haskell.Brittany.Internal.Config.Types +import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified System.IO @@ -43,43 +38,9 @@ parseModule -> System.IO.FilePath -> (GHC.DynFlags -> IO (Either String a)) -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule = - parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout - --- | Parse a module with specific instructions for the C pre-processor. -parseModuleWithCpp - :: ExactPrint.CppOptions - -> ExactPrint.DeltaOptions - -> [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModuleWithCpp cpp opts args fp dynCheck = - ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ GHC.getSessionDynFlags - (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine - dflags0 - (GHC.noLoc <$> ("-hide-all-packages" : args)) - -- that we pass -hide-all-packages here is a duplication, because - -- ExactPrint.initDynFlags also does it, but necessary because of - -- stupid and careless GHC API design. We explicitly want to pass - -- our args before calling that, so this is what we do. Should be - -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063. - void $ lift $ GHC.setSessionDynFlags dflags1 - dflags2 <- lift $ ExactPrint.initDynFlags fp - unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " - ++ show (leftover <&> \(L _ s) -> s) - unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " - ++ show (warnings <&> warnExtractorCompat) - x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 - res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp - either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) - (\(a, m) -> pure (a, m, x)) - $ ExactPrint.postParseTransform res opts +parseModule args fp dynCheck = do + str <- System.IO.readFile fp + parseModuleFromString args fp dynCheck str parseModuleFromString :: [String] @@ -87,31 +48,7 @@ parseModuleFromString -> (GHC.DynFlags -> IO (Either String a)) -> String -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModuleFromString args fp dynCheck str = - -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will - -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we - -- cannot kill the parsing thread - not very nice. But i'll - -- optimistically assume that most of the time brittany uses noticable or - -- longer time, the majority of the time is not spend in parsing, but in - -- bridoc transformation stuff. - -- (reminder to update note on `parsePrintModule` if this changes.) - mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str - (dflags1, leftover, warnings) <- lift - $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) - unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " - ++ show (leftover <&> \(L _ s) -> s) - unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " - ++ show (warnings <&> warnExtractorCompat) - dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 - let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str - case res of - Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) - Right (a , m ) -> pure (a, m, dynCheckRes) +parseModuleFromString = ParseModule.parseModule commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs new file mode 100644 index 0000000..fa84f02 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs @@ -0,0 +1,508 @@ +{-# OPTIONS_GHC -Wno-implicit-prelude #-} + +module Language.Haskell.Brittany.Internal.ParseModule where + +import qualified Control.Monad as Monad +import qualified Control.Monad.IO.Class as IO +import qualified Control.Monad.Trans.Except as Except +import qualified Data.Set as Set +import qualified GHC +import qualified GHC.ByteOrder +import qualified GHC.Data.Bag +import qualified GHC.Data.EnumSet +import qualified GHC.Data.StringBuffer +import qualified GHC.Driver.CmdLine +import qualified GHC.Driver.Session +import qualified GHC.Parser.Header +import qualified GHC.Platform +import qualified GHC.Settings +import qualified GHC.Types.Basic +import qualified GHC.Types.SrcLoc +import qualified GHC.Unit.Module.Name +import qualified GHC.Unit.State +import qualified GHC.Unit.Types +import qualified GHC.Utils.Error +import qualified GHC.Utils.Fingerprint +import qualified GHC.Utils.Misc +import qualified GHC.Utils.Ppr.Colour +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint + +-- | Parses a Haskell module. Although this nominally requires IO, it is +-- morally pure. It should have no observable effects. +parseModule + :: IO.MonadIO io + => [String] + -> FilePath + -> (GHC.Driver.Session.DynFlags -> io (Either String a)) + -> String + -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do + let + dynFlags1 = GHC.Driver.Session.gopt_set + -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both + -- of those modes have trouble parsing safe imports (@import safe ...@). + -- Neither passing in @"-XUnsafe"@ as a command line argument nor having + -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. + initialDynFlags + { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe + } + GHC.Driver.Session.Opt_KeepRawTokenStream + (dynFlags2, leftovers1, warnings1) <- + GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 + $ fmap GHC.Types.SrcLoc.noLoc arguments1 + handleLeftovers leftovers1 + handleWarnings warnings1 + let + stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string + arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath + (dynFlags3, leftovers2, warnings2) <- + GHC.Driver.Session.parseDynamicFilePragma dynFlags2 arguments2 + handleLeftovers leftovers2 + handleWarnings warnings2 + dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 + let + parseResult = + ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string + case parseResult of + Left errorMessages -> handleErrorMessages errorMessages + Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) + +handleLeftovers + :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () +handleLeftovers leftovers = + Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show + (fmap GHC.Types.SrcLoc.unLoc leftovers) + +handleWarnings + :: Monad m => [GHC.Driver.CmdLine.Warn] -> Except.ExceptT String m () +handleWarnings warnings = + Monad.unless (null warnings) . Except.throwE $ "warnings: " <> show + (fmap (GHC.Types.SrcLoc.unLoc . GHC.Driver.CmdLine.warnMsg) warnings) + +handleErrorMessages + :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a +handleErrorMessages = + Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList + +initialCfgWeights :: GHC.Driver.Session.CfgWeights +initialCfgWeights = GHC.Driver.Session.CFGWeights + { GHC.Driver.Session.backEdgeBonus = 0 + , GHC.Driver.Session.callWeight = 0 + , GHC.Driver.Session.condBranchWeight = 0 + , GHC.Driver.Session.infoTablePenalty = 0 + , GHC.Driver.Session.likelyCondWeight = 0 + , GHC.Driver.Session.switchWeight = 0 + , GHC.Driver.Session.uncondWeight = 0 + , GHC.Driver.Session.unlikelyCondWeight = 0 + } + +initialDynFlags :: GHC.Driver.Session.DynFlags +initialDynFlags = GHC.Driver.Session.DynFlags + { GHC.Driver.Session.avx = False + , GHC.Driver.Session.avx2 = False + , GHC.Driver.Session.avx512cd = False + , GHC.Driver.Session.avx512er = False + , GHC.Driver.Session.avx512f = False + , GHC.Driver.Session.avx512pf = False + , GHC.Driver.Session.binBlobThreshold = 0 + , GHC.Driver.Session.bmiVersion = Nothing + , GHC.Driver.Session.cachedPlugins = [] + , GHC.Driver.Session.canGenerateDynamicToo = error "canGenerateDynamicToo" + , GHC.Driver.Session.canUseColor = False + , GHC.Driver.Session.cfgWeightInfo = initialCfgWeights + , GHC.Driver.Session.cmdlineFrameworks = [] + , GHC.Driver.Session.cmmProcAlignment = Nothing + , GHC.Driver.Session.colScheme = GHC.Utils.Ppr.Colour.defaultScheme + , GHC.Driver.Session.debugLevel = 0 + , GHC.Driver.Session.depExcludeMods = [] + , GHC.Driver.Session.depIncludeCppDeps = False + , GHC.Driver.Session.depIncludePkgDeps = False + , GHC.Driver.Session.depMakefile = "" + , GHC.Driver.Session.depSuffixes = [] + , GHC.Driver.Session.dirsToClean = error "dirsToClean" + , GHC.Driver.Session.dump_action = \_ _ _ _ _ _ -> pure () + , GHC.Driver.Session.dumpDir = Nothing + , GHC.Driver.Session.dumpFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.dumpPrefix = Nothing + , GHC.Driver.Session.dumpPrefixForce = Nothing + , GHC.Driver.Session.dylibInstallName = Nothing + , GHC.Driver.Session.dynHiSuf = "" + , GHC.Driver.Session.dynLibLoader = GHC.Driver.Session.Deployable + , GHC.Driver.Session.dynObjectSuf = "" + , GHC.Driver.Session.dynOutputFile = Nothing + , GHC.Driver.Session.enableTimeStats = False + , GHC.Driver.Session.extensionFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.extensions = [] + , GHC.Driver.Session.fatalWarningFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.fileSettings = initialFileSettings + , GHC.Driver.Session.filesToClean = error "filesToClean" + , GHC.Driver.Session.floatLamArgs = Nothing + , GHC.Driver.Session.flushErr = GHC.Driver.Session.defaultFlushErr + , GHC.Driver.Session.flushOut = GHC.Driver.Session.defaultFlushOut + , GHC.Driver.Session.frameworkPaths = [] + , GHC.Driver.Session.frontendPluginOpts = [] + , GHC.Driver.Session.generalFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.generatedDumps = error "generatedDumps" + , GHC.Driver.Session.ghcHeapSize = Nothing + , GHC.Driver.Session.ghciHistSize = 0 + , GHC.Driver.Session.ghciScripts = [] + , GHC.Driver.Session.ghcLink = GHC.Driver.Session.NoLink + , GHC.Driver.Session.ghcMode = GHC.Driver.Session.OneShot + , GHC.Driver.Session.ghcNameVersion = initialGhcNameVersion + , GHC.Driver.Session.ghcVersionFile = Nothing + , GHC.Driver.Session.haddockOptions = Nothing + , GHC.Driver.Session.hcSuf = "" + , GHC.Driver.Session.hiDir = Nothing + , GHC.Driver.Session.hieDir = Nothing + , GHC.Driver.Session.hieSuf = "" + , GHC.Driver.Session.historySize = 0 + , GHC.Driver.Session.hiSuf = "" + , GHC.Driver.Session.homeUnitId = GHC.Unit.Types.stringToUnitId "" + , GHC.Driver.Session.homeUnitInstanceOfId = Nothing + , GHC.Driver.Session.homeUnitInstantiations = [] + , GHC.Driver.Session.hooks = error "hooks" + , GHC.Driver.Session.hpcDir = "" + , GHC.Driver.Session.hscTarget = GHC.Driver.Session.HscNothing + , GHC.Driver.Session.ignorePackageFlags = [] + , GHC.Driver.Session.importPaths = [] + , GHC.Driver.Session.includePaths = initialIncludeSpecs + , GHC.Driver.Session.incoherentOnLoc = initialSrcSpan + , GHC.Driver.Session.initialUnique = 0 + , GHC.Driver.Session.inlineCheck = Nothing + , GHC.Driver.Session.interactivePrint = Nothing + , GHC.Driver.Session.language = Nothing + , GHC.Driver.Session.ldInputs = [] + , GHC.Driver.Session.liberateCaseThreshold = Nothing + , GHC.Driver.Session.libraryPaths = [] + , GHC.Driver.Session.liftLamsKnown = False + , GHC.Driver.Session.liftLamsNonRecArgs = Nothing + , GHC.Driver.Session.liftLamsRecArgs = Nothing + , GHC.Driver.Session.llvmConfig = initialLlvmConfig + , GHC.Driver.Session.log_action = \_ _ _ _ _ -> pure () + , GHC.Driver.Session.mainFunIs = Nothing + , GHC.Driver.Session.mainModIs = GHC.Unit.Types.mkModule + (GHC.Unit.Types.stringToUnit "") + (GHC.Unit.Module.Name.mkModuleName "") + , GHC.Driver.Session.maxErrors = Nothing + , GHC.Driver.Session.maxInlineAllocSize = 0 + , GHC.Driver.Session.maxInlineMemcpyInsns = 0 + , GHC.Driver.Session.maxInlineMemsetInsns = 0 + , GHC.Driver.Session.maxPmCheckModels = 0 + , GHC.Driver.Session.maxRefHoleFits = Nothing + , GHC.Driver.Session.maxRelevantBinds = Nothing + , GHC.Driver.Session.maxSimplIterations = 0 + , GHC.Driver.Session.maxUncoveredPatterns = 0 + , GHC.Driver.Session.maxValidHoleFits = Nothing + , GHC.Driver.Session.maxWorkerArgs = 0 + , GHC.Driver.Session.newDerivOnLoc = initialSrcSpan + , GHC.Driver.Session.nextTempSuffix = error "nextTempSuffix" + , GHC.Driver.Session.nextWrapperNum = error "nextWrapperNum" + , GHC.Driver.Session.objectDir = Nothing + , GHC.Driver.Session.objectSuf = "" + , GHC.Driver.Session.optLevel = 0 + , GHC.Driver.Session.outputFile = Nothing + , GHC.Driver.Session.outputHi = Nothing + , GHC.Driver.Session.overlapInstLoc = initialSrcSpan + , GHC.Driver.Session.packageDBFlags = [] + , GHC.Driver.Session.packageEnv = Nothing + , GHC.Driver.Session.packageFlags = [] + , GHC.Driver.Session.parMakeCount = Nothing + , GHC.Driver.Session.pkgTrustOnLoc = initialSrcSpan + , GHC.Driver.Session.platformConstants = initialPlatformConstants + , GHC.Driver.Session.platformMisc = initialPlatformMisc + , GHC.Driver.Session.pluginModNameOpts = [] + , GHC.Driver.Session.pluginModNames = [] + , GHC.Driver.Session.pluginPackageFlags = [] + , GHC.Driver.Session.pprCols = 80 + , GHC.Driver.Session.pprUserLength = 0 + , GHC.Driver.Session.profAuto = GHC.Driver.Session.NoProfAuto + , GHC.Driver.Session.rawSettings = [] + , GHC.Driver.Session.reductionDepth = GHC.Types.Basic.mkIntWithInf 0 + , GHC.Driver.Session.refLevelHoleFits = Nothing + , GHC.Driver.Session.reverseErrors = False + , GHC.Driver.Session.rtccInfo = error "rtccInfo" + , GHC.Driver.Session.rtldInfo = error "rtldInfo" + , GHC.Driver.Session.rtsOpts = Nothing + , GHC.Driver.Session.rtsOptsEnabled = GHC.Driver.Session.RtsOptsNone + , GHC.Driver.Session.rtsOptsSuggestions = False + , GHC.Driver.Session.ruleCheck = Nothing + , GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Ignore + , GHC.Driver.Session.safeInfer = False + , GHC.Driver.Session.safeInferred = False + , GHC.Driver.Session.simplPhases = 0 + , GHC.Driver.Session.simplTickFactor = 0 + , GHC.Driver.Session.solverIterations = GHC.Types.Basic.mkIntWithInf 0 + , GHC.Driver.Session.specConstrCount = Nothing + , GHC.Driver.Session.specConstrRecursive = 0 + , GHC.Driver.Session.specConstrThreshold = Nothing + , GHC.Driver.Session.splitInfo = Nothing + , GHC.Driver.Session.sseVersion = Nothing + , GHC.Driver.Session.staticPlugins = [] + , GHC.Driver.Session.strictnessBefore = [] + , GHC.Driver.Session.stubDir = Nothing + , GHC.Driver.Session.targetPlatform = initialTargetPlatform + , GHC.Driver.Session.thOnLoc = initialSrcSpan + , GHC.Driver.Session.toolSettings = initialToolSettings + , GHC.Driver.Session.trace_action = \_ _ _ a -> a + , GHC.Driver.Session.trustFlags = [] + , GHC.Driver.Session.trustworthyOnLoc = initialSrcSpan + , GHC.Driver.Session.ufCreationThreshold = 0 + , GHC.Driver.Session.ufDearOp = 0 + , GHC.Driver.Session.ufDictDiscount = 0 + , GHC.Driver.Session.ufFunAppDiscount = 0 + , GHC.Driver.Session.ufUseThreshold = 0 + , GHC.Driver.Session.ufVeryAggressive = False + , GHC.Driver.Session.uniqueIncrement = 0 + , GHC.Driver.Session.unitDatabases = Nothing + , GHC.Driver.Session.unitState = GHC.Unit.State.emptyUnitState + , GHC.Driver.Session.useColor = GHC.Utils.Misc.Never + , GHC.Driver.Session.useUnicode = False + , GHC.Driver.Session.verbosity = 0 + , GHC.Driver.Session.warningFlags = GHC.Data.EnumSet.fromList [] + , GHC.Driver.Session.warnSafeOnLoc = initialSrcSpan + , GHC.Driver.Session.warnUnsafeOnLoc = initialSrcSpan + , GHC.Driver.Session.ways = Set.empty + } + +initialFileSettings :: GHC.Driver.Session.FileSettings +initialFileSettings = GHC.Driver.Session.FileSettings + { GHC.Driver.Session.fileSettings_ghciUsagePath = "" + , GHC.Driver.Session.fileSettings_ghcUsagePath = "" + , GHC.Driver.Session.fileSettings_globalPackageDatabase = "" + , GHC.Driver.Session.fileSettings_tmpDir = "" + , GHC.Driver.Session.fileSettings_toolDir = Nothing + , GHC.Driver.Session.fileSettings_topDir = "" + } + +initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion +initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion + { GHC.Driver.Session.ghcNameVersion_programName = "" + , GHC.Driver.Session.ghcNameVersion_projectVersion = "" + } + +initialIncludeSpecs :: GHC.Driver.Session.IncludeSpecs +initialIncludeSpecs = GHC.Driver.Session.IncludeSpecs + { GHC.Driver.Session.includePathsGlobal = [] + , GHC.Driver.Session.includePathsQuote = [] + } + +initialLlvmConfig :: GHC.Driver.Session.LlvmConfig +initialLlvmConfig = GHC.Driver.Session.LlvmConfig + { GHC.Driver.Session.llvmPasses = [] + , GHC.Driver.Session.llvmTargets = [] + } + +initialPlatformConstants :: GHC.Settings.PlatformConstants +initialPlatformConstants = GHC.Settings.PlatformConstants + { GHC.Settings.pc_AP_STACK_SPLIM = 0 + , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0 + , GHC.Settings.pc_BLOCK_SIZE = 0 + , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0 + , GHC.Settings.pc_CINT_SIZE = 0 + , GHC.Settings.pc_CLONG_LONG_SIZE = 0 + , GHC.Settings.pc_CLONG_SIZE = 0 + , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0 + , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False + , GHC.Settings.pc_ILDV_CREATE_MASK = 0 + , GHC.Settings.pc_ILDV_STATE_CREATE = 0 + , GHC.Settings.pc_ILDV_STATE_USE = 0 + , GHC.Settings.pc_LDV_SHIFT = 0 + , GHC.Settings.pc_MAX_CHARLIKE = 0 + , GHC.Settings.pc_MAX_Double_REG = 0 + , GHC.Settings.pc_MAX_Float_REG = 0 + , GHC.Settings.pc_MAX_INTLIKE = 0 + , GHC.Settings.pc_MAX_Long_REG = 0 + , GHC.Settings.pc_MAX_Real_Double_REG = 0 + , GHC.Settings.pc_MAX_Real_Float_REG = 0 + , GHC.Settings.pc_MAX_Real_Long_REG = 0 + , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0 + , GHC.Settings.pc_MAX_Real_XMM_REG = 0 + , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0 + , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0 + , GHC.Settings.pc_MAX_Vanilla_REG = 0 + , GHC.Settings.pc_MAX_XMM_REG = 0 + , GHC.Settings.pc_MIN_CHARLIKE = 0 + , GHC.Settings.pc_MIN_INTLIKE = 0 + , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0 + , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0 + , GHC.Settings.pc_OFFSET_bdescr_blocks = 0 + , GHC.Settings.pc_OFFSET_bdescr_flags = 0 + , GHC.Settings.pc_OFFSET_bdescr_free = 0 + , GHC.Settings.pc_OFFSET_bdescr_start = 0 + , GHC.Settings.pc_OFFSET_Capability_r = 0 + , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0 + , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0 + , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0 + , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0 + , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0 + , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 + , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0 + , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0 + , GHC.Settings.pc_OFFSET_stgGCFun = 0 + , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0 + , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0 + , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0 + , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0 + , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0 + , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 + , GHC.Settings.pc_OFFSET_StgStack_sp = 0 + , GHC.Settings.pc_OFFSET_StgStack_stack = 0 + , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0 + , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0 + , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0 + , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0 + , GHC.Settings.pc_PROF_HDR_SIZE = 0 + , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0 + , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0 + , GHC.Settings.pc_REP_StgEntCounter_allocd = 0 + , GHC.Settings.pc_REP_StgEntCounter_allocs = 0 + , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0 + , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0 + , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0 + , GHC.Settings.pc_RESERVED_STACK_WORDS = 0 + , GHC.Settings.pc_SIZEOF_CostCentreStack = 0 + , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0 + , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0 + , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 + , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 + , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0 + , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 + , GHC.Settings.pc_STD_HDR_SIZE = 0 + , GHC.Settings.pc_TAG_BITS = 0 + , GHC.Settings.pc_TICKY_BIN_COUNT = 0 + , GHC.Settings.pc_WORD_SIZE = 0 + } + +initialPlatformMini :: GHC.Settings.PlatformMini +initialPlatformMini = GHC.Settings.PlatformMini + { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 + , GHC.Settings.platformMini_os = GHC.Platform.OSLinux + } + +initialPlatformMisc :: GHC.Driver.Session.PlatformMisc +initialPlatformMisc = GHC.Driver.Session.PlatformMisc + { GHC.Driver.Session.platformMisc_ghcDebugged = False + , GHC.Driver.Session.platformMisc_ghcRTSWays = "" + , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False + , GHC.Driver.Session.platformMisc_ghcThreaded = False + , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False + , GHC.Driver.Session.platformMisc_ghcWithSMP = False + , GHC.Driver.Session.platformMisc_libFFI = False + , GHC.Driver.Session.platformMisc_llvmTarget = "" + , GHC.Driver.Session.platformMisc_targetPlatformString = "" + } + +initialSrcSpan :: GHC.Types.SrcLoc.SrcSpan +initialSrcSpan = + GHC.Types.SrcLoc.UnhelpfulSpan GHC.Types.SrcLoc.UnhelpfulNoLocationInfo + +initialTargetPlatform :: GHC.Settings.Platform +initialTargetPlatform = GHC.Settings.Platform + { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian + , GHC.Settings.platformHasGnuNonexecStack = False + , GHC.Settings.platformHasIdentDirective = False + , GHC.Settings.platformHasSubsectionsViaSymbols = False + , GHC.Settings.platformIsCrossCompiling = False + , GHC.Settings.platformLeadingUnderscore = False + , GHC.Settings.platformMini = initialPlatformMini + , GHC.Settings.platformTablesNextToCode = False + , GHC.Settings.platformUnregisterised = False + , GHC.Settings.platformWordSize = GHC.Platform.PW8 + } + +initialToolSettings :: GHC.Settings.ToolSettings +initialToolSettings = GHC.Settings.ToolSettings + { GHC.Settings.toolSettings_ccSupportsNoPie = False + , GHC.Settings.toolSettings_extraGccViaCFlags = [] + , GHC.Settings.toolSettings_ldIsGnuLd = False + , GHC.Settings.toolSettings_ldSupportsBuildId = False + , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False + , GHC.Settings.toolSettings_ldSupportsFilelist = False + , GHC.Settings.toolSettings_opt_a = [] + , GHC.Settings.toolSettings_opt_c = [] + , GHC.Settings.toolSettings_opt_cxx = [] + , GHC.Settings.toolSettings_opt_F = [] + , GHC.Settings.toolSettings_opt_i = [] + , GHC.Settings.toolSettings_opt_l = [] + , GHC.Settings.toolSettings_opt_L = [] + , GHC.Settings.toolSettings_opt_lc = [] + , GHC.Settings.toolSettings_opt_lcc = [] + , GHC.Settings.toolSettings_opt_lm = [] + , GHC.Settings.toolSettings_opt_lo = [] + , GHC.Settings.toolSettings_opt_P = [] + , GHC.Settings.toolSettings_opt_P_fingerprint = + GHC.Utils.Fingerprint.fingerprint0 + , GHC.Settings.toolSettings_opt_windres = [] + , GHC.Settings.toolSettings_pgm_a = ("", []) + , GHC.Settings.toolSettings_pgm_ar = "" + , GHC.Settings.toolSettings_pgm_c = "" + , GHC.Settings.toolSettings_pgm_dll = ("", []) + , GHC.Settings.toolSettings_pgm_F = "" + , GHC.Settings.toolSettings_pgm_i = "" + , GHC.Settings.toolSettings_pgm_install_name_tool = "" + , GHC.Settings.toolSettings_pgm_l = ("", []) + , GHC.Settings.toolSettings_pgm_L = "" + , GHC.Settings.toolSettings_pgm_lc = ("", []) + , GHC.Settings.toolSettings_pgm_lcc = ("", []) + , GHC.Settings.toolSettings_pgm_libtool = "" + , GHC.Settings.toolSettings_pgm_lm = ("", []) + , GHC.Settings.toolSettings_pgm_lo = ("", []) + , GHC.Settings.toolSettings_pgm_otool = "" + , GHC.Settings.toolSettings_pgm_P = ("", []) + , GHC.Settings.toolSettings_pgm_ranlib = "" + , GHC.Settings.toolSettings_pgm_T = "" + , GHC.Settings.toolSettings_pgm_windres = "" + } -- 2.30.2 From 89a9f47b72a7d41cce19a49e8503440101cfb8ac Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 21 Nov 2021 23:40:15 +0000 Subject: [PATCH 462/478] Ignore warnings when parsing modules --- data/10-tests.blt | 70 ++++++++----------- data/15-regressions.blt | 3 +- data/30-tests-context-free.blt | 66 ++++++++--------- .../Haskell/Brittany/Internal/ParseModule.hs | 16 ++--- 4 files changed, 62 insertions(+), 93 deletions(-) diff --git a/data/10-tests.blt b/data/10-tests.blt index 311c911..debf9aa 100644 --- a/data/10-tests.blt +++ b/data/10-tests.blt @@ -35,7 +35,7 @@ func :: (((((((((()))))))))) -- current output is.. funny. wonder if that can/needs to be improved.. #test give me more! -#pending +#pending nested tuples over line length func :: ((((((((((((((((((((((((((((((((((((((((((())))))))))))))))))))))))))))))))))))))))))) #test unit @@ -196,7 +196,7 @@ func ] ############################################################################### #test type operator stuff -#pending +#pending HsOpTy test050 :: a :+: b test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd @@ -258,20 +258,18 @@ funcA :: a -> b -- comment A funcB :: a -> b -- comment B #test comments all -#pending -- a func -- b :: -- c - a -- d + a -- d -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j + ( -- f + c -- g + , -- h + d -- i + ) -- j -- k - ############################################################################### ############################################################################### ############################################################################### @@ -303,10 +301,9 @@ func = f func :: Int #test inline pragma 4 -#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2. func = f where - {-# INLINE [~] f #-} + {-# INLINE [~1] f #-} f = id @@ -363,7 +360,6 @@ data MyRecord = MyConstructor } #test record with DataTypeContexts -#pending data type contexts are deprecated in ghc 9.0 {-# LANGUAGE DatatypeContexts #-} data ( LooooooooooooooooooooongConstraint a @@ -647,21 +643,15 @@ x *** y = x func _ = x #test simple long pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = + x #test simple multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = x #test another multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - a - b +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b = x #test simple constructor @@ -671,7 +661,6 @@ func (A a) = a func (x : xr) = x #test some other constructor symbol -#pending func (x :+: xr) = x #test normal infix constructor @@ -738,21 +727,21 @@ describe "infix op" $ do func = x + x #test long -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj #test long keep linemode 1 -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj #test long keep linemode 2 -#pending -func = mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj +func = + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj #test literals func = 1 @@ -816,9 +805,10 @@ myTupleSection = ) #test 2 -#pending -func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) +func = + ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + ) #test comment-after-then foo = if True @@ -1400,12 +1390,10 @@ type Foo a -- fancy type comment Int #test synonym-type-operators -#pending - type (a :+: b) = (a, b) #test synonym-multi-parens -#pending +#pending loses extra parens type ((a :+: b) c) = (a, c) diff --git a/data/15-regressions.blt b/data/15-regressions.blt index df2dada..9a6b623 100644 --- a/data/15-regressions.blt +++ b/data/15-regressions.blt @@ -134,11 +134,10 @@ func = if x 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 + Seq.EmptyL -> return $ Seq.empty x1 Seq.:< xR -> do x1' <- docSeq [prepElem, return x1] return $ x1' Seq.<| xR diff --git a/data/30-tests-context-free.blt b/data/30-tests-context-free.blt index 003a23d..d73e6d4 100644 --- a/data/30-tests-context-free.blt +++ b/data/30-tests-context-free.blt @@ -35,7 +35,7 @@ func :: (((((((((()))))))))) -- current output is.. funny. wonder if that can/needs to be improved.. #test give me more! -#pending +#pending nested tuples over line length func :: ((((((((((((((((((((((((((((((((((((((((((())))))))))))))))))))))))))))))))))))))))))) #test unit @@ -196,7 +196,7 @@ func ] ############################################################################### #test type operator stuff -#pending +#pending HsOpTy test050 :: a :+: b test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd @@ -249,18 +249,16 @@ funcA :: a -> b -- comment A funcB :: a -> b -- comment B #test comments all -#pending -- a func -- b :: -- c - a -- d + a -- d -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j --- k + ( -- f + c -- g + , -- h + d -- i + ) -- j-- k ############################################################################### @@ -305,10 +303,9 @@ func = 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 #-} + {-# INLINE [~1] f #-} f = id @@ -390,21 +387,15 @@ x *** y = x func _ = x #test simple long pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = + x #test simple multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = x #test another multiline pattern -#pending -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - a - b +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b = x #test simple constructor @@ -414,7 +405,6 @@ func (A a) = a func (x : xr) = x #test some other constructor symbol -#pending func (x :+: xr) = x @@ -479,21 +469,21 @@ describe "infix op" $ do func = x + x #test long -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj #test long keep linemode 1 -#pending -func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj #test long keep linemode 2 -#pending -func = mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj +func = + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj #test literals func = 1 @@ -551,9 +541,10 @@ func = (`abc` 1) func = (abc, def) #test 2 -#pending -func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) +func = + ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + ) #test let in on single line foo = @@ -1082,7 +1073,6 @@ func = if x else Nothing #test qualified infix pattern -#pending "TODO" wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs index fa84f02..2cc259f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs @@ -11,7 +11,6 @@ import qualified GHC.ByteOrder import qualified GHC.Data.Bag import qualified GHC.Data.EnumSet import qualified GHC.Data.StringBuffer -import qualified GHC.Driver.CmdLine import qualified GHC.Driver.Session import qualified GHC.Parser.Header import qualified GHC.Platform @@ -48,18 +47,17 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe } GHC.Driver.Session.Opt_KeepRawTokenStream - (dynFlags2, leftovers1, warnings1) <- + (dynFlags2, leftovers1, _) <- GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 $ fmap GHC.Types.SrcLoc.noLoc arguments1 handleLeftovers leftovers1 - handleWarnings warnings1 let stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath - (dynFlags3, leftovers2, warnings2) <- - GHC.Driver.Session.parseDynamicFilePragma dynFlags2 arguments2 + (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma + dynFlags2 + arguments2 handleLeftovers leftovers2 - handleWarnings warnings2 dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 let parseResult = @@ -74,12 +72,6 @@ handleLeftovers leftovers = Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show (fmap GHC.Types.SrcLoc.unLoc leftovers) -handleWarnings - :: Monad m => [GHC.Driver.CmdLine.Warn] -> Except.ExceptT String m () -handleWarnings warnings = - Monad.unless (null warnings) . Except.throwE $ "warnings: " <> show - (fmap (GHC.Types.SrcLoc.unLoc . GHC.Driver.CmdLine.warnMsg) warnings) - handleErrorMessages :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a handleErrorMessages = -- 2.30.2 From 21e86adf6edaffe886b8e5311836a4d9657ec6ab Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Tue, 23 Nov 2021 22:41:01 +0000 Subject: [PATCH 463/478] Split tests into individual files --- brittany.cabal | 4 +- data/10-tests.blt | 1757 ----------------- data/14-extensions.blt | 241 --- data/15-regressions.blt | 874 -------- data/16-pending.blt | 35 - data/30-tests-context-free.blt | 1461 -------------- data/40-indent-policy-multiple.blt | 42 - data/Test1.hs | 1 + data/Test10.hs | 3 + data/Test100.hs | 1 + data/Test101.hs | 3 + data/Test102.hs | 3 + data/Test103.hs | 1 + data/Test104.hs | 1 + data/Test105.hs | 1 + data/Test106.hs | 1 + data/Test107.hs | 1 + data/Test108.hs | 1 + data/Test109.hs | 1 + data/Test11.hs | 3 + data/Test110.hs | 6 + data/Test111.hs | 4 + data/Test112.hs | 6 + data/Test113.hs | 5 + data/Test114.hs | 3 + data/Test115.hs | 7 + data/Test116.hs | 7 + data/Test117.hs | 1 + data/Test118.hs | 5 + data/Test119.hs | 5 + data/Test12.hs | 5 + data/Test120.hs | 3 + data/Test121.hs | 3 + data/Test122.hs | 3 + data/Test123.hs | 7 + data/Test124.hs | 4 + data/Test125.hs | 4 + data/Test126.hs | 3 + data/Test127.hs | 6 + data/Test128.hs | 6 + data/Test129.hs | 1 + data/Test13.hs | 5 + data/Test130.hs | 1 + data/Test131.hs | 1 + data/Test132.hs | 1 + data/Test133.hs | 12 + data/Test134.hs | 12 + data/Test135.hs | 1 + data/Test136.hs | 1 + data/Test137.hs | 1 + data/Test138.hs | 6 + data/Test139.hs | 1 + data/Test14.hs | 1 + data/Test140.hs | 1 + data/Test141.hs | 1 + data/Test142.hs | 1 + data/Test143.hs | 1 + data/Test144.hs | 1 + data/Test145.hs | 1 + data/Test146.hs | 1 + data/Test147.hs | 1 + data/Test148.hs | 1 + data/Test149.hs | 1 + data/Test15.hs | 5 + data/Test150.hs | 3 + data/Test151.hs | 1 + data/Test152.hs | 1 + data/Test153.hs | 4 + data/Test154.hs | 14 + data/Test155.hs | 11 + data/Test156.hs | 3 + data/Test157.hs | 13 + data/Test158.hs | 3 + data/Test159.hs | 3 + data/Test16.hs | 6 + data/Test160.hs | 3 + data/Test161.hs | 10 + data/Test162.hs | 11 + data/Test163.hs | 9 + data/Test164.hs | 7 + data/Test165.hs | 4 + data/Test166.hs | 3 + data/Test167.hs | 8 + data/Test168.hs | 2 + data/Test169.hs | 8 + data/Test17.hs | 6 + data/Test170.hs | 18 + data/Test171.hs | 2 + data/Test172.hs | 26 + data/Test173.hs | 2 + data/Test174.hs | 5 + data/Test175.hs | 2 + data/Test176.hs | 3 + data/Test177.hs | 2 + data/Test178.hs | 1 + data/Test179.hs | 1 + data/Test18.hs | 5 + data/Test180.hs | 3 + data/Test181.hs | 7 + data/Test182.hs | 7 + data/Test183.hs | 1 + data/Test184.hs | 5 + data/Test185.hs | 2 + data/Test186.hs | 1 + data/Test187.hs | 1 + data/Test188.hs | 1 + data/Test189.hs | 1 + data/Test19.hs | 7 + data/Test190.hs | 3 + data/Test191.hs | 1 + data/Test192.hs | 6 + data/Test193.hs | 2 + data/Test194.hs | 4 + data/Test195.hs | 3 + data/Test196.hs | 9 + data/Test197.hs | 3 + data/Test198.hs | 11 + data/Test199.hs | 4 + data/Test2.hs | 3 + data/Test20.hs | 7 + data/Test200.hs | 4 + data/Test201.hs | 5 + data/Test202.hs | 8 + data/Test203.hs | 11 + data/Test204.hs | 6 + data/Test205.hs | 4 + data/Test206.hs | 3 + data/Test207.hs | 3 + data/Test208.hs | 4 + data/Test209.hs | 3 + data/Test21.hs | 7 + data/Test210.hs | 3 + data/Test211.hs | 4 + data/Test212.hs | 3 + data/Test213.hs | 3 + data/Test214.hs | 4 + data/Test215.hs | 5 + data/Test216.hs | 5 + data/Test217.hs | 6 + data/Test218.hs | 5 + data/Test219.hs | 5 + data/Test22.hs | 7 + data/Test220.hs | 6 + data/Test221.hs | 5 + data/Test222.hs | 5 + data/Test223.hs | 6 + data/Test224.hs | 3 + data/Test225.hs | 10 + data/Test226.hs | 1 + data/Test227.hs | 1 + data/Test228.hs | 4 + data/Test229.hs | 3 + data/Test23.hs | 1 + data/Test230.hs | 4 + data/Test231.hs | 6 + data/Test232.hs | 4 + data/Test233.hs | 2 + data/Test234.hs | 7 + data/Test235.hs | 5 + data/Test236.hs | 6 + data/Test237.hs | 3 + data/Test238.hs | 7 + data/Test239.hs | 2 + data/Test24.hs | 4 + data/Test240.hs | 2 + data/Test241.hs | 3 + data/Test242.hs | 3 + data/Test243.hs | 2 + data/Test244.hs | 2 + data/Test245.hs | 3 + data/Test246.hs | 4 + data/Test247.hs | 3 + data/Test248.hs | 6 + data/Test249.hs | 7 + data/Test25.hs | 5 + data/Test250.hs | 6 + data/Test251.hs | 2 + data/Test252.hs | 7 + data/Test253.hs | 4 + data/Test254.hs | 4 + data/Test255.hs | 5 + data/Test256.hs | 4 + data/Test257.hs | 6 + data/Test258.hs | 9 + data/Test259.hs | 2 + data/Test26.hs | 1 + data/Test260.hs | 2 + data/Test261.hs | 2 + data/Test262.hs | 2 + data/Test263.hs | 3 + data/Test264.hs | 4 + data/Test265.hs | 1 + data/Test266.hs | 4 + data/Test267.hs | 3 + data/Test268.hs | 5 + data/Test269.hs | 6 + data/Test27.hs | 1 + data/Test270.hs | 1 + data/Test271.hs | 4 + data/Test272.hs | 4 + data/Test273.hs | 4 + data/Test274.hs | 6 + data/Test275.hs | 6 + data/Test276.hs | 7 + data/Test277.hs | 2 + data/Test278.hs | 4 + data/Test279.hs | 6 + data/Test28.hs | 5 + data/Test280.hs | 5 + data/Test281.hs | 5 + data/Test282.hs | 7 + data/Test283.hs | 6 + data/Test284.hs | 24 + data/Test285.hs | 12 + data/Test286.hs | 12 + data/Test287.hs | 35 + data/Test288.hs | 2 + data/Test289.hs | 6 + data/Test29.hs | 6 + data/Test290.hs | 2 + data/Test291.hs | 5 + data/Test292.hs | 7 + data/Test293.hs | 5 + data/Test294.hs | 2 + data/Test295.hs | 1 + data/Test296.hs | 5 + data/Test297.hs | 3 + data/Test298.hs | 14 + data/Test299.hs | 3 + data/Test3.hs | 4 + data/Test30.hs | 6 + data/Test300.hs | 4 + data/Test301.hs | 5 + data/Test302.hs | 18 + data/Test303.hs | 2 + data/Test304.hs | 9 + data/Test305.hs | 11 + data/Test306.hs | 7 + data/Test307.hs | 2 + data/Test308.hs | 50 + data/Test309.hs | 9 + data/Test31.hs | 2 + data/Test310.hs | 5 + data/Test311.hs | 5 + data/Test312.hs | 2 + data/Test313.hs | 2 + data/Test314.hs | 2 + data/Test315.hs | 1 + data/Test316.hs | 1 + data/Test317.hs | 1 + data/Test318.hs | 7 + data/Test319.hs | 13 + data/Test32.hs | 10 + data/Test320.hs | 2 + data/Test321.hs | 1 + data/Test322.hs | 2 + data/Test323.hs | 7 + data/Test324.hs | 9 + data/Test325.hs | 4 + data/Test326.hs | 4 + data/Test327.hs | 1 + data/Test328.hs | 3 + data/Test329.hs | 7 + data/Test33.hs | 10 + data/Test330.hs | 10 + data/Test331.hs | 5 + data/Test332.hs | 2 + data/Test333.hs | 18 + data/Test334.hs | 5 + data/Test335.hs | 12 + data/Test336.hs | 8 + data/Test337.hs | 4 + data/Test338.hs | 1 + data/Test339.hs | 5 + data/Test34.hs | 9 + data/Test340.hs | 2 + data/Test341.hs | 3 + data/Test342.hs | 50 + data/Test343.hs | 10 + data/Test344.hs | 7 + data/Test345.hs | 13 + data/Test346.hs | 2 + data/Test347.hs | 8 + data/Test348.hs | 8 + data/Test349.hs | 6 + data/Test35.hs | 2 + data/Test350.hs | 23 + data/Test351.hs | 7 + data/Test352.hs | 5 + data/Test353.hs | 4 + data/Test354.hs | 4 + data/Test355.hs | 5 + data/Test356.hs | 11 + data/Test357.hs | 7 + data/Test358.hs | 2 + data/Test359.hs | 4 + data/Test36.hs | 1 + data/Test360.hs | 5 + data/Test361.hs | 2 + data/Test362.hs | 2 + data/Test363.hs | 2 + data/Test364.hs | 3 + data/Test365.hs | 2 + data/Test366.hs | 6 + data/Test367.hs | 4 + data/Test368.hs | 4 + data/Test369.hs | 6 + data/Test37.hs | 2 + data/Test370.hs | 6 + data/Test371.hs | 2 + data/Test372.hs | 6 + data/Test373.hs | 7 + data/Test374.hs | 7 + data/Test375.hs | 6 + data/Test376.hs | 8 + data/Test377.hs | 8 + data/Test378.hs | 8 + data/Test379.hs | 8 + data/Test38.hs | 11 + data/Test380.hs | 2 + data/Test381.hs | 5 + data/Test382.hs | 6 + data/Test383.hs | 2 + data/Test384.hs | 2 + data/Test385.hs | 6 + data/Test386.hs | 7 + data/Test387.hs | 7 + data/Test388.hs | 3 + data/Test389.hs | 11 + data/Test39.hs | 4 + data/Test390.hs | 11 + data/Test391.hs | 3 + data/Test392.hs | 2 + data/Test393.hs | 3 + data/Test394.hs | 11 + data/Test395.hs | 3 + data/Test396.hs | 8 + data/Test397.hs | 5 + data/Test398.hs | 5 + data/Test399.hs | 5 + data/Test4.hs | 1 + data/Test40.hs | 4 + data/Test400.hs | 5 + data/Test401.hs | 4 + data/Test402.hs | 4 + data/Test403.hs | 5 + data/Test404.hs | 5 + data/Test405.hs | 6 + data/Test406.hs | 6 + data/Test407.hs | 2 + data/Test408.hs | 2 + data/Test409.hs | 2 + data/Test41.hs | 4 + data/Test410.hs | 2 + data/Test411.hs | 3 + data/Test412.hs | 3 + data/Test413.hs | 3 + data/Test414.hs | 2 + data/Test415.hs | 2 + data/Test416.hs | 2 + data/Test417.hs | 2 + data/Test418.hs | 4 + data/Test419.hs | 4 + data/Test42.hs | 2 + data/Test420.hs | 8 + data/Test421.hs | 6 + data/Test422.hs | 7 + data/Test423.hs | 3 + data/Test424.hs | 2 + data/Test425.hs | 4 + data/Test426.hs | 5 + data/Test427.hs | 5 + data/Test428.hs | 6 + data/Test429.hs | 5 + data/Test43.hs | 4 + data/Test430.hs | 3 + data/Test431.hs | 2 + data/Test432.hs | 4 + data/Test433.hs | 5 + data/Test434.hs | 2 + data/Test435.hs | 2 + data/Test436.hs | 2 + data/Test437.hs | 2 + data/Test438.hs | 2 + data/Test439.hs | 5 + data/Test44.hs | 2 + data/Test440.hs | 4 + data/Test441.hs | 4 + data/Test442.hs | 4 + data/Test443.hs | 4 + data/Test444.hs | 8 + data/Test445.hs | 5 + data/Test446.hs | 7 + data/Test447.hs | 7 + data/Test448.hs | 2 + data/Test449.hs | 2 + data/Test45.hs | 3 + data/Test450.hs | 2 + data/Test451.hs | 2 + data/Test452.hs | 13 + data/Test453.hs | 13 + data/Test454.hs | 2 + data/Test455.hs | 2 + data/Test456.hs | 2 + data/Test457.hs | 2 + data/Test458.hs | 2 + data/Test459.hs | 2 + data/Test46.hs | 3 + data/Test460.hs | 2 + data/Test461.hs | 2 + data/Test462.hs | 2 + data/Test463.hs | 2 + data/Test464.hs | 2 + data/Test465.hs | 2 + data/Test466.hs | 2 + data/Test467.hs | 2 + data/Test468.hs | 4 + data/Test469.hs | 2 + data/Test47.hs | 4 + data/Test470.hs | 2 + data/Test471.hs | 2 + data/Test472.hs | 16 + data/Test473.hs | 2 + data/Test474.hs | 3 + data/Test475.hs | 15 + data/Test476.hs | 5 + data/Test477.hs | 3 + data/Test478.hs | 3 + data/Test479.hs | 3 + data/Test48.hs | 4 + data/Test480.hs | 2 + data/Test481.hs | 5 + data/Test482.hs | 6 + data/Test483.hs | 5 + data/Test484.hs | 12 + data/Test485.hs | 4 + data/Test486.hs | 3 + data/Test487.hs | 27 + data/Test488.hs | 3 + data/Test489.hs | 25 + data/Test49.hs | 5 + data/Test490.hs | 5 + data/Test491.hs | 2 + data/Test492.hs | 6 + data/Test493.hs | 6 + data/Test494.hs | 6 + data/Test495.hs | 6 + data/Test496.hs | 4 + data/Test497.hs | 7 + data/Test498.hs | 7 + data/Test499.hs | 2 + data/Test5.hs | 1 + data/Test50.hs | 8 + data/Test500.hs | 5 + data/Test501.hs | 6 + data/Test502.hs | 5 + data/Test503.hs | 7 + data/Test504.hs | 7 + data/Test505.hs | 8 + data/Test506.hs | 3 + data/Test507.hs | 5 + data/Test508.hs | 8 + data/Test509.hs | 6 + data/Test51.hs | 13 + data/Test510.hs | 6 + data/Test511.hs | 8 + data/Test512.hs | 7 + data/Test513.hs | 25 + data/Test514.hs | 13 + data/Test515.hs | 13 + data/Test516.hs | 37 + data/Test517.hs | 4 + data/Test518.hs | 7 + data/Test519.hs | 4 + data/Test52.hs | 5 + data/Test520.hs | 3 + data/Test521.hs | 6 + data/Test522.hs | 8 + data/Test523.hs | 6 + data/Test524.hs | 3 + data/Test525.hs | 2 + data/Test526.hs | 6 + data/Test527.hs | 4 + data/Test528.hs | 15 + data/Test529.hs | 4 + data/Test53.hs | 7 + data/Test530.hs | 6 + data/Test531.hs | 6 + data/Test532.hs | 20 + data/Test533.hs | 3 + data/Test534.hs | 11 + data/Test535.hs | 3 + data/Test536.hs | 51 + data/Test537.hs | 11 + data/Test538.hs | 6 + data/Test539.hs | 7 + data/Test54.hs | 10 + data/Test540.hs | 14 + data/Test55.hs | 9 + data/Test56.hs | 14 + data/Test57.hs | 5 + data/Test58.hs | 12 + data/Test59.hs | 6 + data/Test6.hs | 1 + data/Test60.hs | 4 + data/Test61.hs | 5 + data/Test62.hs | 3 + data/Test63.hs | 5 + data/Test64.hs | 5 + data/Test65.hs | 9 + data/Test66.hs | 11 + data/Test67.hs | 13 + data/Test68.hs | 8 + data/Test69.hs | 4 + data/Test7.hs | 2 + data/Test70.hs | 3 + data/Test71.hs | 4 + data/Test72.hs | 3 + data/Test73.hs | 22 + data/Test74.hs | 1 + data/Test75.hs | 1 + data/Test76.hs | 1 + data/Test77.hs | 1 + data/Test78.hs | 4 + data/Test79.hs | 1 + data/Test8.hs | 1 + data/Test80.hs | 2 + data/Test81.hs | 2 + data/Test82.hs | 2 + data/Test83.hs | 1 + data/Test84.hs | 1 + data/Test85.hs | 1 + data/Test86.hs | 1 + data/Test87.hs | 1 + data/Test88.hs | 2 + data/Test89.hs | 3 + data/Test9.hs | 5 + data/Test90.hs | 7 + data/Test91.hs | 5 + data/Test92.hs | 6 + data/Test93.hs | 2 + data/Test94.hs | 1 + data/Test95.hs | 3 + data/Test96.hs | 4 + data/Test97.hs | 4 + data/Test98.hs | 5 + data/Test99.hs | 2 + data/brittany.yaml | 4 + .../library/Language/Haskell/Brittany/Main.hs | 12 +- source/test-suite/Main.hs | 294 +-- 550 files changed, 2918 insertions(+), 4663 deletions(-) delete mode 100644 data/10-tests.blt delete mode 100644 data/14-extensions.blt delete mode 100644 data/15-regressions.blt delete mode 100644 data/16-pending.blt delete mode 100644 data/30-tests-context-free.blt delete mode 100644 data/40-indent-policy-multiple.blt create mode 100644 data/Test1.hs create mode 100644 data/Test10.hs create mode 100644 data/Test100.hs create mode 100644 data/Test101.hs create mode 100644 data/Test102.hs create mode 100644 data/Test103.hs create mode 100644 data/Test104.hs create mode 100644 data/Test105.hs create mode 100644 data/Test106.hs create mode 100644 data/Test107.hs create mode 100644 data/Test108.hs create mode 100644 data/Test109.hs create mode 100644 data/Test11.hs create mode 100644 data/Test110.hs create mode 100644 data/Test111.hs create mode 100644 data/Test112.hs create mode 100644 data/Test113.hs create mode 100644 data/Test114.hs create mode 100644 data/Test115.hs create mode 100644 data/Test116.hs create mode 100644 data/Test117.hs create mode 100644 data/Test118.hs create mode 100644 data/Test119.hs create mode 100644 data/Test12.hs create mode 100644 data/Test120.hs create mode 100644 data/Test121.hs create mode 100644 data/Test122.hs create mode 100644 data/Test123.hs create mode 100644 data/Test124.hs create mode 100644 data/Test125.hs create mode 100644 data/Test126.hs create mode 100644 data/Test127.hs create mode 100644 data/Test128.hs create mode 100644 data/Test129.hs create mode 100644 data/Test13.hs create mode 100644 data/Test130.hs create mode 100644 data/Test131.hs create mode 100644 data/Test132.hs create mode 100644 data/Test133.hs create mode 100644 data/Test134.hs create mode 100644 data/Test135.hs create mode 100644 data/Test136.hs create mode 100644 data/Test137.hs create mode 100644 data/Test138.hs create mode 100644 data/Test139.hs create mode 100644 data/Test14.hs create mode 100644 data/Test140.hs create mode 100644 data/Test141.hs create mode 100644 data/Test142.hs create mode 100644 data/Test143.hs create mode 100644 data/Test144.hs create mode 100644 data/Test145.hs create mode 100644 data/Test146.hs create mode 100644 data/Test147.hs create mode 100644 data/Test148.hs create mode 100644 data/Test149.hs create mode 100644 data/Test15.hs create mode 100644 data/Test150.hs create mode 100644 data/Test151.hs create mode 100644 data/Test152.hs create mode 100644 data/Test153.hs create mode 100644 data/Test154.hs create mode 100644 data/Test155.hs create mode 100644 data/Test156.hs create mode 100644 data/Test157.hs create mode 100644 data/Test158.hs create mode 100644 data/Test159.hs create mode 100644 data/Test16.hs create mode 100644 data/Test160.hs create mode 100644 data/Test161.hs create mode 100644 data/Test162.hs create mode 100644 data/Test163.hs create mode 100644 data/Test164.hs create mode 100644 data/Test165.hs create mode 100644 data/Test166.hs create mode 100644 data/Test167.hs create mode 100644 data/Test168.hs create mode 100644 data/Test169.hs create mode 100644 data/Test17.hs create mode 100644 data/Test170.hs create mode 100644 data/Test171.hs create mode 100644 data/Test172.hs create mode 100644 data/Test173.hs create mode 100644 data/Test174.hs create mode 100644 data/Test175.hs create mode 100644 data/Test176.hs create mode 100644 data/Test177.hs create mode 100644 data/Test178.hs create mode 100644 data/Test179.hs create mode 100644 data/Test18.hs create mode 100644 data/Test180.hs create mode 100644 data/Test181.hs create mode 100644 data/Test182.hs create mode 100644 data/Test183.hs create mode 100644 data/Test184.hs create mode 100644 data/Test185.hs create mode 100644 data/Test186.hs create mode 100644 data/Test187.hs create mode 100644 data/Test188.hs create mode 100644 data/Test189.hs create mode 100644 data/Test19.hs create mode 100644 data/Test190.hs create mode 100644 data/Test191.hs create mode 100644 data/Test192.hs create mode 100644 data/Test193.hs create mode 100644 data/Test194.hs create mode 100644 data/Test195.hs create mode 100644 data/Test196.hs create mode 100644 data/Test197.hs create mode 100644 data/Test198.hs create mode 100644 data/Test199.hs create mode 100644 data/Test2.hs create mode 100644 data/Test20.hs create mode 100644 data/Test200.hs create mode 100644 data/Test201.hs create mode 100644 data/Test202.hs create mode 100644 data/Test203.hs create mode 100644 data/Test204.hs create mode 100644 data/Test205.hs create mode 100644 data/Test206.hs create mode 100644 data/Test207.hs create mode 100644 data/Test208.hs create mode 100644 data/Test209.hs create mode 100644 data/Test21.hs create mode 100644 data/Test210.hs create mode 100644 data/Test211.hs create mode 100644 data/Test212.hs create mode 100644 data/Test213.hs create mode 100644 data/Test214.hs create mode 100644 data/Test215.hs create mode 100644 data/Test216.hs create mode 100644 data/Test217.hs create mode 100644 data/Test218.hs create mode 100644 data/Test219.hs create mode 100644 data/Test22.hs create mode 100644 data/Test220.hs create mode 100644 data/Test221.hs create mode 100644 data/Test222.hs create mode 100644 data/Test223.hs create mode 100644 data/Test224.hs create mode 100644 data/Test225.hs create mode 100644 data/Test226.hs create mode 100644 data/Test227.hs create mode 100644 data/Test228.hs create mode 100644 data/Test229.hs create mode 100644 data/Test23.hs create mode 100644 data/Test230.hs create mode 100644 data/Test231.hs create mode 100644 data/Test232.hs create mode 100644 data/Test233.hs create mode 100644 data/Test234.hs create mode 100644 data/Test235.hs create mode 100644 data/Test236.hs create mode 100644 data/Test237.hs create mode 100644 data/Test238.hs create mode 100644 data/Test239.hs create mode 100644 data/Test24.hs create mode 100644 data/Test240.hs create mode 100644 data/Test241.hs create mode 100644 data/Test242.hs create mode 100644 data/Test243.hs create mode 100644 data/Test244.hs create mode 100644 data/Test245.hs create mode 100644 data/Test246.hs create mode 100644 data/Test247.hs create mode 100644 data/Test248.hs create mode 100644 data/Test249.hs create mode 100644 data/Test25.hs create mode 100644 data/Test250.hs create mode 100644 data/Test251.hs create mode 100644 data/Test252.hs create mode 100644 data/Test253.hs create mode 100644 data/Test254.hs create mode 100644 data/Test255.hs create mode 100644 data/Test256.hs create mode 100644 data/Test257.hs create mode 100644 data/Test258.hs create mode 100644 data/Test259.hs create mode 100644 data/Test26.hs create mode 100644 data/Test260.hs create mode 100644 data/Test261.hs create mode 100644 data/Test262.hs create mode 100644 data/Test263.hs create mode 100644 data/Test264.hs create mode 100644 data/Test265.hs create mode 100644 data/Test266.hs create mode 100644 data/Test267.hs create mode 100644 data/Test268.hs create mode 100644 data/Test269.hs create mode 100644 data/Test27.hs create mode 100644 data/Test270.hs create mode 100644 data/Test271.hs create mode 100644 data/Test272.hs create mode 100644 data/Test273.hs create mode 100644 data/Test274.hs create mode 100644 data/Test275.hs create mode 100644 data/Test276.hs create mode 100644 data/Test277.hs create mode 100644 data/Test278.hs create mode 100644 data/Test279.hs create mode 100644 data/Test28.hs create mode 100644 data/Test280.hs create mode 100644 data/Test281.hs create mode 100644 data/Test282.hs create mode 100644 data/Test283.hs create mode 100644 data/Test284.hs create mode 100644 data/Test285.hs create mode 100644 data/Test286.hs create mode 100644 data/Test287.hs create mode 100644 data/Test288.hs create mode 100644 data/Test289.hs create mode 100644 data/Test29.hs create mode 100644 data/Test290.hs create mode 100644 data/Test291.hs create mode 100644 data/Test292.hs create mode 100644 data/Test293.hs create mode 100644 data/Test294.hs create mode 100644 data/Test295.hs create mode 100644 data/Test296.hs create mode 100644 data/Test297.hs create mode 100644 data/Test298.hs create mode 100644 data/Test299.hs create mode 100644 data/Test3.hs create mode 100644 data/Test30.hs create mode 100644 data/Test300.hs create mode 100644 data/Test301.hs create mode 100644 data/Test302.hs create mode 100644 data/Test303.hs create mode 100644 data/Test304.hs create mode 100644 data/Test305.hs create mode 100644 data/Test306.hs create mode 100644 data/Test307.hs create mode 100644 data/Test308.hs create mode 100644 data/Test309.hs create mode 100644 data/Test31.hs create mode 100644 data/Test310.hs create mode 100644 data/Test311.hs create mode 100644 data/Test312.hs create mode 100644 data/Test313.hs create mode 100644 data/Test314.hs create mode 100644 data/Test315.hs create mode 100644 data/Test316.hs create mode 100644 data/Test317.hs create mode 100644 data/Test318.hs create mode 100644 data/Test319.hs create mode 100644 data/Test32.hs create mode 100644 data/Test320.hs create mode 100644 data/Test321.hs create mode 100644 data/Test322.hs create mode 100644 data/Test323.hs create mode 100644 data/Test324.hs create mode 100644 data/Test325.hs create mode 100644 data/Test326.hs create mode 100644 data/Test327.hs create mode 100644 data/Test328.hs create mode 100644 data/Test329.hs create mode 100644 data/Test33.hs create mode 100644 data/Test330.hs create mode 100644 data/Test331.hs create mode 100644 data/Test332.hs create mode 100644 data/Test333.hs create mode 100644 data/Test334.hs create mode 100644 data/Test335.hs create mode 100644 data/Test336.hs create mode 100644 data/Test337.hs create mode 100644 data/Test338.hs create mode 100644 data/Test339.hs create mode 100644 data/Test34.hs create mode 100644 data/Test340.hs create mode 100644 data/Test341.hs create mode 100644 data/Test342.hs create mode 100644 data/Test343.hs create mode 100644 data/Test344.hs create mode 100644 data/Test345.hs create mode 100644 data/Test346.hs create mode 100644 data/Test347.hs create mode 100644 data/Test348.hs create mode 100644 data/Test349.hs create mode 100644 data/Test35.hs create mode 100644 data/Test350.hs create mode 100644 data/Test351.hs create mode 100644 data/Test352.hs create mode 100644 data/Test353.hs create mode 100644 data/Test354.hs create mode 100644 data/Test355.hs create mode 100644 data/Test356.hs create mode 100644 data/Test357.hs create mode 100644 data/Test358.hs create mode 100644 data/Test359.hs create mode 100644 data/Test36.hs create mode 100644 data/Test360.hs create mode 100644 data/Test361.hs create mode 100644 data/Test362.hs create mode 100644 data/Test363.hs create mode 100644 data/Test364.hs create mode 100644 data/Test365.hs create mode 100644 data/Test366.hs create mode 100644 data/Test367.hs create mode 100644 data/Test368.hs create mode 100644 data/Test369.hs create mode 100644 data/Test37.hs create mode 100644 data/Test370.hs create mode 100644 data/Test371.hs create mode 100644 data/Test372.hs create mode 100644 data/Test373.hs create mode 100644 data/Test374.hs create mode 100644 data/Test375.hs create mode 100644 data/Test376.hs create mode 100644 data/Test377.hs create mode 100644 data/Test378.hs create mode 100644 data/Test379.hs create mode 100644 data/Test38.hs create mode 100644 data/Test380.hs create mode 100644 data/Test381.hs create mode 100644 data/Test382.hs create mode 100644 data/Test383.hs create mode 100644 data/Test384.hs create mode 100644 data/Test385.hs create mode 100644 data/Test386.hs create mode 100644 data/Test387.hs create mode 100644 data/Test388.hs create mode 100644 data/Test389.hs create mode 100644 data/Test39.hs create mode 100644 data/Test390.hs create mode 100644 data/Test391.hs create mode 100644 data/Test392.hs create mode 100644 data/Test393.hs create mode 100644 data/Test394.hs create mode 100644 data/Test395.hs create mode 100644 data/Test396.hs create mode 100644 data/Test397.hs create mode 100644 data/Test398.hs create mode 100644 data/Test399.hs create mode 100644 data/Test4.hs create mode 100644 data/Test40.hs create mode 100644 data/Test400.hs create mode 100644 data/Test401.hs create mode 100644 data/Test402.hs create mode 100644 data/Test403.hs create mode 100644 data/Test404.hs create mode 100644 data/Test405.hs create mode 100644 data/Test406.hs create mode 100644 data/Test407.hs create mode 100644 data/Test408.hs create mode 100644 data/Test409.hs create mode 100644 data/Test41.hs create mode 100644 data/Test410.hs create mode 100644 data/Test411.hs create mode 100644 data/Test412.hs create mode 100644 data/Test413.hs create mode 100644 data/Test414.hs create mode 100644 data/Test415.hs create mode 100644 data/Test416.hs create mode 100644 data/Test417.hs create mode 100644 data/Test418.hs create mode 100644 data/Test419.hs create mode 100644 data/Test42.hs create mode 100644 data/Test420.hs create mode 100644 data/Test421.hs create mode 100644 data/Test422.hs create mode 100644 data/Test423.hs create mode 100644 data/Test424.hs create mode 100644 data/Test425.hs create mode 100644 data/Test426.hs create mode 100644 data/Test427.hs create mode 100644 data/Test428.hs create mode 100644 data/Test429.hs create mode 100644 data/Test43.hs create mode 100644 data/Test430.hs create mode 100644 data/Test431.hs create mode 100644 data/Test432.hs create mode 100644 data/Test433.hs create mode 100644 data/Test434.hs create mode 100644 data/Test435.hs create mode 100644 data/Test436.hs create mode 100644 data/Test437.hs create mode 100644 data/Test438.hs create mode 100644 data/Test439.hs create mode 100644 data/Test44.hs create mode 100644 data/Test440.hs create mode 100644 data/Test441.hs create mode 100644 data/Test442.hs create mode 100644 data/Test443.hs create mode 100644 data/Test444.hs create mode 100644 data/Test445.hs create mode 100644 data/Test446.hs create mode 100644 data/Test447.hs create mode 100644 data/Test448.hs create mode 100644 data/Test449.hs create mode 100644 data/Test45.hs create mode 100644 data/Test450.hs create mode 100644 data/Test451.hs create mode 100644 data/Test452.hs create mode 100644 data/Test453.hs create mode 100644 data/Test454.hs create mode 100644 data/Test455.hs create mode 100644 data/Test456.hs create mode 100644 data/Test457.hs create mode 100644 data/Test458.hs create mode 100644 data/Test459.hs create mode 100644 data/Test46.hs create mode 100644 data/Test460.hs create mode 100644 data/Test461.hs create mode 100644 data/Test462.hs create mode 100644 data/Test463.hs create mode 100644 data/Test464.hs create mode 100644 data/Test465.hs create mode 100644 data/Test466.hs create mode 100644 data/Test467.hs create mode 100644 data/Test468.hs create mode 100644 data/Test469.hs create mode 100644 data/Test47.hs create mode 100644 data/Test470.hs create mode 100644 data/Test471.hs create mode 100644 data/Test472.hs create mode 100644 data/Test473.hs create mode 100644 data/Test474.hs create mode 100644 data/Test475.hs create mode 100644 data/Test476.hs create mode 100644 data/Test477.hs create mode 100644 data/Test478.hs create mode 100644 data/Test479.hs create mode 100644 data/Test48.hs create mode 100644 data/Test480.hs create mode 100644 data/Test481.hs create mode 100644 data/Test482.hs create mode 100644 data/Test483.hs create mode 100644 data/Test484.hs create mode 100644 data/Test485.hs create mode 100644 data/Test486.hs create mode 100644 data/Test487.hs create mode 100644 data/Test488.hs create mode 100644 data/Test489.hs create mode 100644 data/Test49.hs create mode 100644 data/Test490.hs create mode 100644 data/Test491.hs create mode 100644 data/Test492.hs create mode 100644 data/Test493.hs create mode 100644 data/Test494.hs create mode 100644 data/Test495.hs create mode 100644 data/Test496.hs create mode 100644 data/Test497.hs create mode 100644 data/Test498.hs create mode 100644 data/Test499.hs create mode 100644 data/Test5.hs create mode 100644 data/Test50.hs create mode 100644 data/Test500.hs create mode 100644 data/Test501.hs create mode 100644 data/Test502.hs create mode 100644 data/Test503.hs create mode 100644 data/Test504.hs create mode 100644 data/Test505.hs create mode 100644 data/Test506.hs create mode 100644 data/Test507.hs create mode 100644 data/Test508.hs create mode 100644 data/Test509.hs create mode 100644 data/Test51.hs create mode 100644 data/Test510.hs create mode 100644 data/Test511.hs create mode 100644 data/Test512.hs create mode 100644 data/Test513.hs create mode 100644 data/Test514.hs create mode 100644 data/Test515.hs create mode 100644 data/Test516.hs create mode 100644 data/Test517.hs create mode 100644 data/Test518.hs create mode 100644 data/Test519.hs create mode 100644 data/Test52.hs create mode 100644 data/Test520.hs create mode 100644 data/Test521.hs create mode 100644 data/Test522.hs create mode 100644 data/Test523.hs create mode 100644 data/Test524.hs create mode 100644 data/Test525.hs create mode 100644 data/Test526.hs create mode 100644 data/Test527.hs create mode 100644 data/Test528.hs create mode 100644 data/Test529.hs create mode 100644 data/Test53.hs create mode 100644 data/Test530.hs create mode 100644 data/Test531.hs create mode 100644 data/Test532.hs create mode 100644 data/Test533.hs create mode 100644 data/Test534.hs create mode 100644 data/Test535.hs create mode 100644 data/Test536.hs create mode 100644 data/Test537.hs create mode 100644 data/Test538.hs create mode 100644 data/Test539.hs create mode 100644 data/Test54.hs create mode 100644 data/Test540.hs create mode 100644 data/Test55.hs create mode 100644 data/Test56.hs create mode 100644 data/Test57.hs create mode 100644 data/Test58.hs create mode 100644 data/Test59.hs create mode 100644 data/Test6.hs create mode 100644 data/Test60.hs create mode 100644 data/Test61.hs create mode 100644 data/Test62.hs create mode 100644 data/Test63.hs create mode 100644 data/Test64.hs create mode 100644 data/Test65.hs create mode 100644 data/Test66.hs create mode 100644 data/Test67.hs create mode 100644 data/Test68.hs create mode 100644 data/Test69.hs create mode 100644 data/Test7.hs create mode 100644 data/Test70.hs create mode 100644 data/Test71.hs create mode 100644 data/Test72.hs create mode 100644 data/Test73.hs create mode 100644 data/Test74.hs create mode 100644 data/Test75.hs create mode 100644 data/Test76.hs create mode 100644 data/Test77.hs create mode 100644 data/Test78.hs create mode 100644 data/Test79.hs create mode 100644 data/Test8.hs create mode 100644 data/Test80.hs create mode 100644 data/Test81.hs create mode 100644 data/Test82.hs create mode 100644 data/Test83.hs create mode 100644 data/Test84.hs create mode 100644 data/Test85.hs create mode 100644 data/Test86.hs create mode 100644 data/Test87.hs create mode 100644 data/Test88.hs create mode 100644 data/Test89.hs create mode 100644 data/Test9.hs create mode 100644 data/Test90.hs create mode 100644 data/Test91.hs create mode 100644 data/Test92.hs create mode 100644 data/Test93.hs create mode 100644 data/Test94.hs create mode 100644 data/Test95.hs create mode 100644 data/Test96.hs create mode 100644 data/Test97.hs create mode 100644 data/Test98.hs create mode 100644 data/Test99.hs create mode 100644 data/brittany.yaml diff --git a/brittany.cabal b/brittany.cabal index 84db13f..33d760e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -24,7 +24,8 @@ extra-doc-files: README.md doc/implementation/*.md extra-source-files: - data/*.blt + data/brittany.yaml + data/*.hs source-repository head type: git @@ -143,7 +144,6 @@ test-suite brittany-test-suite build-depends: , hspec ^>= 2.8.3 - , parsec ^>= 3.1.14 hs-source-dirs: source/test-suite main-is: Main.hs type: exitcode-stdio-1.0 diff --git a/data/10-tests.blt b/data/10-tests.blt deleted file mode 100644 index debf9aa..0000000 --- a/data/10-tests.blt +++ /dev/null @@ -1,1757 +0,0 @@ - -############################################################################### -############################################################################### -############################################################################### -#group type signatures -############################################################################### -############################################################################### -############################################################################### - -#test simple001 -func :: a -> a - -#test long typeVar -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test keep linebreak mode -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - -#test simple parens 1 -func :: ((a)) - -#test simple parens 2 -func :: (a -> a) -> a - -#test simple parens 3 -func :: a -> (a -> a) - -#test did anyone say parentheses? -func :: (((((((((()))))))))) - --- current output is.. funny. wonder if that can/needs to be improved.. -#test give me more! -#pending nested tuples over line length -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 HsOpTy -test050 :: a :+: b -test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -############################################################################### - -#test forall oneliner -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b - -#test forall context multiline -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . Foo - => ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () - -#test forall no-context multiline -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () - -#test forall context multiline with comments -{-# LANGUAGE RankNTypes #-} -addFlagStringParam - :: forall f out - . (Applicative f) - => String -- ^ short flag chars, i.e. "v" for -v - -> [String] -- ^ list of long names, i.e. ["verbose"] - -> String -- ^ param name - -> Flag String -- ^ properties - -> CmdParser f out String - -#test language pragma issue -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b - -#test comments 1 -func :: a -> b -- comment - -#test comments 2 -funcA :: a -> b -- comment A -funcB :: a -> b -- comment B - -#test comments all --- a -func -- b - :: -- c - a -- d - -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j --- k - -############################################################################### -############################################################################### -############################################################################### -#group type signatures pragmas -############################################################################### -############################################################################### -############################################################################### - -#test inline pragma 1 -func = f - where - {-# INLINE f #-} - f = id - -#test inline pragma 2 -func = ($) - where - {-# INLINE ($) #-} - ($) = id - -#test inline pragma 3 -func = f - where - {-# INLINE CONLIKE [1] f #-} - f = id - -#test noinline pragma 1 -{-# NOINLINE func #-} -func :: Int - -#test inline pragma 4 -func = f - where - {-# INLINE [~1] f #-} - f = id - - -############################################################################### -############################################################################### -############################################################################### -#group data type declarations -############################################################################### -############################################################################### -############################################################################### - -#test nullary data type -data Foo = Bar {} - -data Biz = Baz - -#test single record -data Foo = Bar - { foo :: Baz - } - -#test record multiple names -data Foo = Bar - { foo, bar :: Baz - } - -#test record multiple types -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -#test record multiple types and names -data Foo = Bar - { foo, biz :: Baz - , bar :: Bizzz - } - -#test record multiple types deriving -data Foo = Bar - { fooz :: Baz - , bar :: Bizzz - } - deriving Show - -#test record long field names -data MyRecord = MyConstructor - { bar1, bar2 - :: Loooooooooooooooooooooooooooooooong - -> Loooooooooooooooooooooooooooooooong - , foo1, foo2 - :: Loooooooooooooooooooooooooooooooonger - -> Loooooooooooooooooooooooooooooooonger - } - -#test record with DataTypeContexts -{-# LANGUAGE DatatypeContexts #-} -data - ( LooooooooooooooooooooongConstraint a - , LooooooooooooooooooooongConstraint b - ) => - MyRecord a b - = MyConstructor - { foo1, foo2 - :: loooooooooooooooooooooooooooooooong - -> loooooooooooooooooooooooooooooooong - , bar :: a - , bazz :: b - } - -#test record single line layout -#pending config flag is disabled for now -{-# LANGUAGE ScopedTypeVariables #-} --- brittany { lconfig_allowSinglelineRecord: true } -data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int } - -#test record no matching single line layout -{-# LANGUAGE ScopedTypeVariables #-} --- brittany { lconfig_allowSinglelineRecord: true } -data MyRecord = forall a . Show a => Bar - { foo :: abittoolongbutnotvery -> abittoolongbutnotvery - } - -#test record forall constraint multiline -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a - . LooooooooooooooooooooongConstraint a => - LoooooooooooongConstructor - { foo :: abittoolongbutnotvery -> abittoolongbutnotvery - } - -#test record forall constraint multiline more -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor - { a :: a - , b :: b - } - -#test plain with forall and constraint -{-# LANGUAGE ScopedTypeVariables #-} -data MyStruct - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor (ToBriDocM BriDocNumbered) - (ToBriDocM BriDocNumbered) - (ToBriDocM BriDocNumbered) - -#test record with many features -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor - { foo, foo2 - :: loooooooooooooooooooooooooooooooong - -> loooooooooooooooooooooooooooooooong - , bar :: a - , bazz :: b - } - deriving Show - -#test record multiple types deriving -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) - -#test record multiple deriving strategies -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving Show - deriving (Eq, Ord) - deriving stock Show - deriving stock (Eq, Ord) - deriving anyclass Show - deriving anyclass (Show, Eq, Monad, Functor) - deriving newtype Show - deriving newtype (Traversable, Foldable) - -#test record deriving via -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving ToJSON via (SomeType) - deriving (ToJSON, FromJSON) via (SomeType) - -#test single record existential -{-# LANGUAGE ExistentialQuantification #-} - -data Foo = forall a . Show a => Bar - { foo :: a - } - -#test record multiple types existential -{-# LANGUAGE ExistentialQuantification #-} - -data Foo = forall a b . (Show a, Eq b) => Bar - { foo :: a - , bars :: b - } - -#test plain comment simple --- before -data MyData = MyData Int --- after - -#test record newline comment -data MyRecord = MyRecord - { a :: Int - -- comment - , b :: Int - } - -#test record comments simple -data Foo = Bar -- a - { foo :: Baz -- b - , bars :: Bizzz -- c - } -- d - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e - -#test record comments strange inline -data Foo = Bar - { -- a - foo -- b - :: -- c - Baz -- d - , -- e - bars :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) - -#test record comments in deriving -## maybe we want to switch to a differnt layout when there are such comments. -## Don't hesitate to modify this testcase, it clearly is not the ideal layout -## for this. - -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -- a - deriving --b - ( -- c - ToJSON -- d - , -- e - FromJSON --f - ) -- g - -#test record comments in deriving via -## maybe we want to switch to a differnt layout when there are such comments. -## Don't hesitate to modify this testcase, it clearly is not the ideal layout -## for this. - -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -- a - deriving --a - ToJSON --b - via -- c - ( -- d - SomeType --e - , -- f - ABC --g - ) - -#test comment before equal sign -{-# LANGUAGE ExistentialQuantification #-} -data MyRecord - -- test comment - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor a b - -#test normal records on multi line indent policy left --- brittany {lconfig_indentPolicy: IndentPolicyLeft } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] - -#test normal records on multi line indent policy free --- brittany {lconfig_indentPolicy: IndentPolicyFree } -data GrantsForCompanyResp = GrantsForCompanyResp Types.Company - [EnterpriseGrantResponse] - -#test normal records on multi line indent policy free 2 --- brittany {lconfig_indentPolicy: IndentPolicyFree } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] - -#test normal records on multi line indent policy multiple --- brittany {lconfig_indentPolicy: IndentPolicyMultiple } -data GrantsForCompanyResp = GrantsForCompanyResp Types.Company - [EnterpriseGrantResponse] - -#test large record with a comment -data XIILqcacwiuNiu = XIILqcacwiuNiu - { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo - , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] - , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo - , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo - , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int - , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq - , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq - , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo - , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn - , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo - , opjUxtkxzkiKse_luqjuZazt - :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] - -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () - , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo - , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn - , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn - , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn - , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn - , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep - , jeyOcuesexaYoy_vpqn :: Jgtoyuh () - } - -############################################################################### -############################################################################### -############################################################################### -#group equation.basic -############################################################################### -############################################################################### -############################################################################### -## some basic testing of different kinds of equations. -## some focus on column layouting for multiple-equation definitions. -## (that part probably is not implemented in any way yet.) - -#test basic 1 -func x = x - -#test infix 1 -x *** y = x - -#test symbol prefix -(***) x y = x - -#test infix more args simple -(f >=> g) k = f k >>= g - -#test infix more args alignment -(Left a <$$> Left dd) e f = True -(Left a <$$> Right d ) e f = True -(Right a <$$> Left d ) e f = False -(Right a <$$> Right dd) e f = True - - -############################################################################### -############################################################################### -############################################################################### -#group equation.patterns -############################################################################### -############################################################################### -############################################################################### - -#test wildcard -func _ = x - -#test simple long pattern -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = - x - -#test simple multiline pattern -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - -#test another multiline pattern -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b - = x - -#test simple constructor -func (A a) = a - -#test list constructor -func (x : xr) = x - -#test some other constructor symbol -func (x :+: xr) = x - -#test normal infix constructor -func (x `Foo` xr) = x - - -############################################################################### -############################################################################### -############################################################################### -#group equation.guards -############################################################################### -############################################################################### -############################################################################### -#test simple guard -func | True = x - -#test multiple-clauses-1 -func x | x = simple expression - | otherwise = 0 - -#test multiple-clauses-2 -func x - | a somewhat longer guard x = "and a somewhat longer expession that does not" - | otherwise = "fit without putting the guards in new lines" - -#test multiple-clauses-3 -func x - | very long guard, another rather long guard that refers to x = nontrivial - expression - foo - bar - alsdkjlasdjlasj - | otherwise = 0 - -#test multiple-clauses-4 -func x - | very long guard, another rather long guard that refers to x - = nontrivialexpression foo bar alsdkjlasdjlasj - | otherwise - = 0 - -#test multiple-clauses-5 -func x - | very loooooooooooooooooooooooooooooong guard - , another rather long guard that refers to x - = nontrivial expression foo bar alsdkjlasdjlasj - | otherwise - = 0 - - -############################################################################### -############################################################################### -############################################################################### -#group expression.basic -############################################################################### -############################################################################### -############################################################################### - -#test var -func = x - -describe "infix op" $ do -#test 1 -func = x + x - -#test long -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test long keep linemode 1 -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - -#test long keep linemode 2 -func = - mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test literals -func = 1 -func = "abc" -func = 1.1e5 -func = 'x' -func = 981409823458910394810928414192837123987123987123 - -#test lambda -func = \x -> abc - -describe "app" $ do -#test 1 -func = klajsdas klajsdas klajsdas - -#test 2 -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - -#test 3 -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas - lakjsdlajsdljas - lakjsdlajsdljas - -### -#group expression.basic.sections -### - -#test left -func = (1 +) - -#test right -func = (+ 1) - -#test left inf -func = (1 `abc`) - -#test right inf -func = (`abc` 1) - -### -#group tuples -### - -#test pair -func = (abc, def) - -#test pair section left -func = (abc, ) - -#test pair section right -func = (, abc) - -#test quintuple section long -myTupleSection = - ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement - , - , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement - , - ) - -#test 2 -func = - ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - ) - -#test comment-after-then -foo = if True - then - -- iiiiii - "a " - else - "b " - -#test comment-after-if-else-do -func = if cond - then pure 42 - else do - -- test - abc - -#test nonempty-case-short -func = case x of - False -> False - True -> True - -#test nonempty-case-long -func = - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of - False -> False - True -> True - -#test nonempty-case-long-do -func = do - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of - False -> False - True -> True - -#test empty-case-short -func = case x of {} - -#test empty-case-long -func = - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of {} - -#test empty-case-long-do -func = do - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of {} - -############################################################################### -############################################################################### -############################################################################### -#group expression.do statements -############################################################################### -############################################################################### -############################################################################### - -#test simple -func = do - stmt - stmt - -#test bind -func = do - x <- stmt - stmt x - -#test let -func = do - let x = 13 - stmt x - - -############################################################################### -############################################################################### -############################################################################### -#group expression.lists -############################################################################### -############################################################################### -############################################################################### - -#test monad-comprehension-case-of -func = - foooooo - $ [ case - foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - of - _ -> True - ] - -############################################################################### -############################################################################### -############################################################################### -#group expression.let -############################################################################### -############################################################################### -############################################################################### - -#test single-bind-comment-long -testMethod foo bar baz qux = - let x = undefined foo bar baz qux qux baz bar :: String - -- some comment explaining the in expression - in undefined foo x :: String - -#test single-bind-comment-short -testMethod foo bar baz qux = - let x = undefined :: String - -- some comment explaining the in expression - in undefined :: String - -#test single-bind-comment-before -testMethod foo bar baz qux = - -- some comment explaining the in expression - let x = undefined :: String in undefined :: String - -#test multiple-binds-comment -foo foo bar baz qux = - let a = 1 - b = 2 - c = 3 - -- some comment explaining the in expression - in undefined :: String - - -############################################################################### -############################################################################### -############################################################################### -#group stylisticspecialcases -############################################################################### -############################################################################### -############################################################################### - -#test operatorprefixalignment-even-with-multiline-alignbreak -func = - foo - $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - ] - ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] - - -############################################################################### -############################################################################### -############################################################################### -#group module -############################################################################### -############################################################################### -############################################################################### - -#test simple -module Main where - -#test no-exports -module Main () where - -#test one-export -module Main (main) where - -#test several-exports -module Main (main, test1, test2) where - -#test many-exports -module Main - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) where - -#test exports-with-comments -module Main - ( main - -- main - , test1 - , test2 - -- Test 3 - , test3 - , test4 - -- Test 5 - , test5 - -- Test 6 - ) where - -#test simple-export-with-things -module Main (Test(..)) where - -#test simple-export-with-module-contents -module Main (module Main) where - -#test export-with-things -module Main (Test(Test, a, b)) where - -#test export-with-things-comment --- comment1 - -module Main - ( Test(Test, a, b) - , foo -- comment2 - ) -- comment3 - where - -#test export-with-empty-thing -module Main (Test()) where - -#test empty-with-comment --- Intentionally left empty - -############################################################################### -############################################################################### -############################################################################### -#group module.import -############################################################################### -############################################################################### -############################################################################### - -#test simple-import -import Data.List - -#test simple-import-alias -import Data.List as L - -#test simple-qualified-import -import qualified Data.List - -#test simple-qualified-import-alias -import qualified Data.List as L - -#test simple-safe -import safe Data.List as L - -#test simple-source -import {-# SOURCE #-} Data.List ( ) - -#test simple-safe-qualified -import safe qualified Data.List - -#test simple-safe-qualified-source -import {-# SOURCE #-} safe qualified Data.List - -#test simple-qualified-package -import qualified "base" Data.List - -#test qualifier-effect -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List ( ) -import {-# SOURCE #-} safe qualified Data.List hiding ( ) - -#test instances-only -import qualified Data.List ( ) - -#test one-element -import Data.List ( nub ) - -#test several-elements -import Data.List ( foldl' - , indexElem - , nub - ) - -#test a-ridiculous-amount-of-elements -import Test ( Long - , anymore - , fit - , items - , line - , list - , not - , onA - , quite - , single - , that - , will - , with - ) - -#test with-things -import Test ( (+) - , (:!)(..) - , (:*)((:.), T7, t7) - , (:.) - , T - , T2() - , T3(..) - , T4(T4) - , T5(T5, t5) - , T6((<|>)) - ) - -#test hiding -import Test hiding ( ) -import Test as T - hiding ( ) - -#test import-hiding-many -import Prelude as X - hiding ( head - , init - , last - , maximum - , minimum - , pred - , read - , readFile - , succ - , tail - , undefined - ) - -#test long-module-name-simple -import TestJustAbitToLongModuleNameLikeThisOneIs - ( ) -import TestJustShortEnoughModuleNameLikeThisOne ( ) - -#test long-module-name-as -import TestJustAbitToLongModuleNameLikeThisOneI - as T -import TestJustShortEnoughModuleNameLikeThisOn as T - -#test long-module-name-hiding -import TestJustAbitToLongModuleNameLikeTh - hiding ( ) -import TestJustShortEnoughModuleNameLike hiding ( ) - -#test long-module-name-simple-items -import MoreThanSufficientlyLongModuleNameWithSome - ( compact - , fit - , inA - , items - , layout - , not - , that - , will - ) - -#test long-module-name-hiding-items -import TestJustAbitToLongModuleNameLikeTh - hiding ( abc - , def - , ghci - , jklm - ) -import TestJustShortEnoughModuleNameLike hiding ( abc - , def - , ghci - , jklm - ) - -#test long-module-name-other -import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) -import {-# SOURCE #-} safe qualified "qualifiers" A - hiding ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff - as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe - ( ) - -#test import-with-comments --- Test -import Data.List ( nub ) -- Test -{- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} - --- Test -import Test ( test ) - -#test import-with-comments-2 - -import Test ( abc - , def - -- comment - ) - -#test import-with-comments-3 - -import Test ( abc - -- comment - ) - -#test import-with-comments-4 -import Test ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) - -#test import-with-comments-5 -import Test ( -- comment - ) - -#test long-bindings -import Test ( longbindingNameThatoverflowsColum - ) -import Test ( Long - ( List - , Of - , Things - ) - ) - -#test things-with-with-comments -import Test ( Thing - ( -- Comments - ) - ) -import Test ( Thing - ( Item - -- and Comment - ) - ) -import Test ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) -#test prefer-dense-empty-list -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine - ( ) - -#test preamble full-preamble -{-# LANGUAGE BangPatterns #-} - -{- - - Test module - -} -module Test - ( test1 - -- ^ test - , test2 - -- | test - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - -- Test 10 - ) where - --- Test -import Data.List ( nub ) -- Test -{- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} - --- Test -import Test ( test ) - -#test sorted-imports -import Aaa -import Baa - -#test sorted-import-groups -import Zaa -import Zab - -import Aaa -import Baa - -#test sorted-qualified-imports -import Boo -import qualified Zoo - -#test imports-groups-same-module -import Boo ( a ) - -import Boo ( b ) - -#test sorted-imports-nested -import A.B.C -import A.B.D - -############################################################################### -############################################################################### -############################################################################### -#group type synonyms -############################################################################### -############################################################################### -############################################################################### - -#test simple-synonym - -type MySynonym = String - -#test parameterised-synonym - -type MySynonym a = [a] - -#test long-function-synonym - --- | Important comment thrown in -type MySynonym b a - = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b - -#test overflowing-function-synonym - -type MySynonym3 b a - = MySynonym a b - -> MySynonym a b - -- ^ RandomComment - -> MyParamType a b - -> MyParamType a b - -> MySynonym2 b a - -#test synonym-with-kind-sig - -{-# LANGUAGE StarIsType #-} - -type MySynonym (a :: * -> *) - = MySynonym a b - -> MySynonym a b - -> MyParamType a b - -> MyParamType a b - -> MySynonym2 b a - -#test synonym-with-constraint - -type MySynonym a = Num a => a -> Int - -#test synonym-overflowing-with-constraint - -type MySynonym a - = Num a - => AReallyLongTypeName - -> AnotherReallyLongTypeName - -> AThirdTypeNameToOverflow - -#test synonym-forall - -{-# LANGUAGE RankNTypes #-} - -type MySynonym = forall a . [a] - -#test synonym-operator - -type (:+:) a b = (a, b) - -#test synonym-infix - -type a `MySynonym` b = a -> b - -#test synonym-infix-operator - -type a :+: b = (a, b) - -#test synonym-infix-parens - -type (a `Foo` b) c = (a, b, c) - -#test synonym-comments - -type Foo a -- fancy type comment - = -- strange comment - Int - -#test synonym-type-operators -type (a :+: b) = (a, b) - -#test synonym-multi-parens -#pending loses extra parens - -type ((a :+: b) c) = (a, c) - -#test synonym-tuple-type-many-comments - -type Foo - = ( -- t1 - A -- t2 - , -- t3 - B -- t4 - ) -- t5 - -############################################################################### -############################################################################### -############################################################################### -#group class.instance -############################################################################### -############################################################################### -############################################################################### - -#test simple-instance - -instance MyClass Int where - myMethod x = x + 1 - -#test simple-method-comment - -instance MyClass Int where - myMethod x = - -- insightful comment - x + 1 - -#test simple-method-signature - -instance MyClass Int where - myMethod :: Int -> Int - myMethod x = x + 1 - -#test simple-long-method-signature - -instance MyClass Int where - myMethod - :: Int - -> Int - -> AReallyLongType - -> AReallyLongType - -> AReallyLongType - -> Int - myMethod x = x + 1 - -#test simple-two-methods - -instance MyClass Int where - myMethod x = x + 1 - myMethod2 x = x + 1 - -#test simple-two-signatures - -instance MyClass Int where - myMethod - :: Int - -> Int - -> AReallyLongType - -> AReallyLongType - -> AReallyLongType - -> Int - myMethod x = x + 1 - - myMethod2 :: Int -> Int - myMethod2 x = x + 1 - -#test simple-instance-comment - --- | This instance should be commented on -instance MyClass Int where - - -- | This method is also comment-worthy - myMethod x = x + 1 - -#test instance-with-type-family - -instance MyClass Int where - type MyType = Int - - myMethod :: MyType -> Int - myMethod x = x + 1 - -#test instance-with-type-family-below-method - -instance MyClass Int where - - type MyType = String - - myMethod :: MyType -> Int - myMethod x = x + 1 - - type MyType = Int - -#test instance-with-data-family - -instance MyClass Int where - - -- | This data is very important - data MyData = IntData - { intData :: String - , intData2 :: Int - } - - myMethod :: MyData -> Int - myMethod = intData2 - -#test instance-with-data-family-below-method - -instance MyClass Int where - -- | This data is important - data MyData = Test Int Int - - myMethod :: MyData -> Int - myMethod = intData2 - - -- | This data is also important - data MyData2 = IntData - { intData :: String - -- ^ Interesting field - , intData2 :: Int - } - -#test instance-with-newtype-family-and-deriving - -{-# LANGUAGE TypeFamilies #-} - -module Lib where - -instance Foo () where - newtype Bar () = Baz () - deriving (Eq, Ord, Show) - bar = Baz - -#test instance-with-newtype-family-and-record - -instance Foo Int where - newtype Bar Int = BarInt - { unBarInt :: Int - } - -############################################################################### -############################################################################### -############################################################################### -#group gh-357 -############################################################################### -############################################################################### -############################################################################### - -#test type-instance-without-comment - -{-# language TypeFamilies #-} -type family F a -type instance F Int = IO Int - -#test type-instance-with-comment - -{-# language TypeFamilies #-} -type family F a -type instance F Int = IO Int -- x - -#test type-instance-with-module-header - -{-# language TypeFamilies #-} -module M where -type family F a -type instance F Int = IO Int - -#test newtype-instance-without-comment - -{-# language TypeFamilies #-} -data family F a -newtype instance F Int = N Int - -#test newtype-instance-with-comment - -{-# language TypeFamilies #-} -data family F a -newtype instance F Int = N Int -- x - -#test newtype-instance-with-module-header - -{-# language TypeFamilies #-} -module M where -data family F a -newtype instance F Int = N Int - -#test data-instance-without-comment - -{-# language TypeFamilies #-} -data family F a -data instance F Int = D Int - -#test data-instance-with-comment - -{-# language TypeFamilies #-} -data family F a -data instance F Int = D Int -- x - -#test data-instance-with-module-header - -{-# language TypeFamilies #-} -module M where -data family F a -data instance F Int = D Int - -#test instance-type-without-comment - -{-# language TypeFamilies #-} -class C a where - type family F a -instance C Int where - type F Int = IO Int - -#test instance-type-with-comment - -{-# language TypeFamilies #-} -class C a where - type family F a -instance C Int where - type F Int = IO Int -- x - -#test instance-type-with-module-header - -{-# language TypeFamilies #-} -module M where -class C a where - type family F a -instance C Int where - type F Int = IO Int - -#test instance-newtype-without-comment - -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - newtype F Int = N Int - -#test instance-newtype-with-comment - -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - newtype F Int = N Int -- x - -#test instance-newtype-with-module-header - -{-# language TypeFamilies #-} -module M where -class C a where - data family F a -instance C Int where - newtype F Int = N Int - -#test instance-data-without-comment - -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - data F Int = D Int - -#test instance-data-with-comment - -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - data F Int = D Int -- x - -#test instance-data-with-module-header - -{-# language TypeFamilies #-} -module M where -class C a where - data family F a -instance C Int where - data F Int = D Int - -############################################################################### -############################################################################### -############################################################################### -#group whitespace-newlines -############################################################################### -############################################################################### -############################################################################### - -#test module-import-newlines - -module Main where - -import Prelude - -firstDecl = True - -#test function-where-newlines - -func = do - - -- complex first step - aaa - - -- complex second step - bbb - - where - - helper :: Helper - helper = helpful - - other :: Other - other = True - - -############################################################################### -############################################################################### -############################################################################### -#group typefam.instance -############################################################################### -############################################################################### -############################################################################### - -#test simple-typefam-instance - -type instance MyFam Bool = String - -#test simple-typefam-instance-param-type - -type instance MyFam (Maybe a) = a -> Bool - -#test simple-typefam-instance-parens -#pending the parens cause problems since ghc-8.8 - -type instance (MyFam (String -> Int)) = String - -#test simple-typefam-instance-overflow - -type instance MyFam ALongishType - = AMuchLongerTypeThanThat - -> AnEvenLongerTypeThanTheLastOne - -> ShouldDefinitelyOverflow - -#test simple-typefam-instance-comments - --- | A happy family -type instance MyFam Bool -- This is an odd one - = AnotherType -- Here's another - -#test simple-typefam-instance-parens-comment -#pending the parens cause problems since ghc-8.8 - --- | A happy family -type instance (MyFam Bool) -- This is an odd one - = -- Here's another - AnotherType diff --git a/data/14-extensions.blt b/data/14-extensions.blt deleted file mode 100644 index 18fc24f..0000000 --- a/data/14-extensions.blt +++ /dev/null @@ -1,241 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group extensions -############################################################################### -############################################################################### -############################################################################### - -############################################################################### -## MultiWayIf -#test multiwayif 1 -{-# LANGUAGE MultiWayIf #-} -func = if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - -#test multiwayif 2 -{-# LANGUAGE MultiWayIf #-} -func = do - foo - bar $ if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - - -############################################################################### -## LambdaCase -#test lambdacase 1 -{-# LANGUAGE LambdaCase #-} -func = \case - FooBar -> x - Baz -> y - - - -############################################################################### -## ImplicitParams -#test ImplicitParams 1 -{-# LANGUAGE ImplicitParams #-} -func :: (?asd::Int) -> () - -#test ImplicitParams 2 -{-# LANGUAGE ImplicitParams #-} -func - :: ( ?asd - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> () - - -############################################################################### -## RecursiveDo -#test recursivedo 1 -{-# LANGUAGE RecursiveDo #-} -foo = do - rec a <- f b - b <- g a - return (a, b) - -#test recursivedo 2 -{-# LANGUAGE RecursiveDo #-} -foo = do - rec -- comment - a <- f b - b <- g a - return (a, b) - -############################################################################### -## ExplicitNamespaces + PatternSynonyms -#test explicitnamespaces_patternsynonyms export -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} -module Test (type (++), (++), pattern Foo) where - -#test explicitnamespaces_patternsynonyms import -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} -import Test ( type (++) - , (++) - , pattern (:.) - , pattern Foo - ) - -############################################################################### -## PatternSynonyms -#test bidirectional pattern -{-# LANGUAGE PatternSynonyms #-} -pattern J x = Just x - -#test unidirection pattern -{-# LANGUAGE PatternSynonyms #-} -pattern F x <- (x, _) - -#test explicitly bidirectional pattern -{-# LANGUAGE PatternSynonyms #-} -pattern HeadC x <- x : xs where - HeadC x = [x] - -#test Multiple arguments -{-# LANGUAGE PatternSynonyms #-} -pattern Head2 x y <- x : y : xs where - Head2 x y = [x, y] - -#test Infix argument -{-# LANGUAGE PatternSynonyms #-} -pattern x :> y = [x, y] - -#test Record argument -{-# LANGUAGE PatternSynonyms #-} -pattern MyData { a, b, c } = [a, b, c] - -#test long pattern match -{-# LANGUAGE PatternSynonyms #-} -pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = - [myLongLeftVariableName, myLongRightVariableName] - -#test long explicitly bidirectional match -{-# LANGUAGE PatternSynonyms #-} -pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- - [myLongLeftVariableName, myLongRightVariableName] where - MyInfixPatternMatcher x y = [x, x, y] - -#test Pattern synonym types -{-# LANGUAGE PatternSynonyms #-} -pattern J :: a -> Maybe a -pattern J x = Just x - -#test pattern synonym bidirectional multiple cases -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed x <- (asSigned -> x) where - Signed (Neg x) = -x - Signed Zero = 0 - Signed (Pos x) = x - -#test pattern synonym bidirectional multiple cases long -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- - (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where - Signed (Neg x) = -x - Signed Zero = 0 - Signed (Pos x) = x - -#test pattern synonym bidirectional multiple cases with comments -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed x <- (asSigned -> x) where - Signed (Neg x) = -x -- negative comment - Signed Zero = 0 -- zero comment - Signed (Pos x) = x -- positive comment - -#test Pattern synonym types multiple names -{-# LANGUAGE PatternSynonyms #-} -pattern J, K :: a -> Maybe a - -#test Pattern synonym type sig wrapped -{-# LANGUAGE PatternSynonyms #-} -pattern LongMatcher - :: longlongtypevar - -> longlongtypevar - -> longlongtypevar - -> Maybe [longlongtypevar] -pattern LongMatcher x y z = Just [x, y, z] - - -############################################################################### -## UnboxedTuples + MagicHash -#test unboxed-tuple and vanilla names -{-# LANGUAGE UnboxedTuples #-} -spanKey :: (# Int, Int #) -> (# Int, Int #) -spanKey = case foo of - (# bar, baz #) -> (# baz, bar #) - -#test unboxed-tuple and hashed name -{-# LANGUAGE MagicHash, UnboxedTuples #-} -spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) -spanKey = case foo of - (# bar#, baz# #) -> (# baz# +# bar#, bar# #) - - -############################################################################### -## QuasiQuotes -#test quasi-quotes simple 1 -{-# LANGUAGE QuasiQuotes #-} -func = [blub| - asd - qwe - |] - -#test quasi-quotes simple 2 -{-# LANGUAGE QuasiQuotes #-} -func = [blub| - asd - qwe|] - -#test quasi-quotes ignoring layouting -{-# LANGUAGE QuasiQuotes #-} -func = do - let body = [json| - hello - |] - pure True - -#test quasi-quotes ignoring layouting, strict mode --- brittany { lconfig_allowHangingQuasiQuotes: False } -{-# LANGUAGE QuasiQuotes #-} -func = do - let - body = - [json| - hello - |] - pure True - -############################################################################### -## OverloadedLabels -#test bare label -{-# LANGUAGE OverloadedLabels #-} -foo = #bar - -#test applied and composed label -{-# LANGUAGE OverloadedLabels #-} -foo = #bar . #baz $ fmap #foo xs - -############################################################################### -## ImplicitParams - -#test IP usage -{-# LANGUAGE ImplicitParams #-} -foo = ?bar - -#test IP binding -{-# LANGUAGE ImplicitParams #-} -foo = let ?bar = Foo in value - -#test IP type signature -{-# LANGUAGE ImplicitParams #-} -foo :: (?bar::Bool) => () -foo = () diff --git a/data/15-regressions.blt b/data/15-regressions.blt deleted file mode 100644 index 9a6b623..0000000 --- a/data/15-regressions.blt +++ /dev/null @@ -1,874 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group regression -############################################################################### -############################################################################### -############################################################################### - -#test newlines-comment -func = do - abc <- foo - ---abc -return () - -#test parenthesis-around-unit -func = (()) - -#test let-defs indentation -func = do - let foo True = True - foo _ = False - return () - -#test record update indentation 1 -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -#test record update indentation 2 -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state - , _lstate_foo = _lstate_foo state - } - -#test record update indentation 3 -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 1 -func = Foo { _lstate_indent = _lstate_indent state } - -#test record construction 2 -func = Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_fooo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 3 -func = do - Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test post-indent comment -func = do --- abc - -- def - return () - -#test post-unindent comment -func = do - do - return () - -- abc - -- def - return () - -#test CPP empty comment case -#pending CPP parsing needs fixing for roundTripEqual -{-# LANGUAGE CPP #-} -module Test where -func = do -#if FOO - let x = 13 -#endif - stmt x - -## really, the following should be handled by forcing the Alt to multiline -## because there are comments. as long as this is not implemented though, -## we should ensure the trivial solution works. -#test comment inline placement (temporary) -func - :: Int -- basic indentation amount - -> Int -- currently used width in current line (after indent) - -- used to accurately calc placing of the current-line - -> LayoutDesc - -> Int - -#test some indentation thingy -func = - ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj - $ abc - $ def - $ ghi - $ jkl - ) - -#test parenthesized operator -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where reassoc (v, e, w) = (v, (e, w)) - -#test record pattern matching stuff -downloadRepoPackage = case repo of - RepoLocal {..} -> return () - RepoLocal { abc } -> return () - RepoLocal{} -> return () - -#test do let comment indentation level problem -func = do - let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' - -- default local dir target if there's no given target - utargets'' = "foo" - return () - -#test list comprehension comment placement -func = - [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_ : _)) <- nosuchFooThing - , gast <- award - ] - -#test if-then-else comment placement -func = if x - then if y -- y is important - then foo - else bar - else Nothing - -#test qualified infix pattern -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR - -#test type signature multiline forcing issue -layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () - -#test multiwayif proper indentation -{-# LANGUAGE MultiWayIf #-} -readMergePersConfig path shouldCreate conf = do - exists <- liftIO $ System.Directory.doesFileExist path - if - | exists -> do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn e - mzero - Right x -> return x - return $ fileConf Semigroup.<> conf - | shouldCreate -> do - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) - staticDefaultConfig - return $ conf - | otherwise -> do - return conf - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _ ) -> InstallOk - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _ ) -> InstallOk - -#test partially overflowing alignment issue" -showPackageDetailedInfo pkginfo = - renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) - $ char '*' - $+$ something - [ entry "Synopsis" synopsis hideIfNull reflowParagraphs - , entry "Versions available" - sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry - "Versions installed" - installedVersions - (altText - null - (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") - ) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description hideIfNull reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) - then empty - else text "Modules:" - $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ] - -#test issue 7a -isValidPosition position | validX && validY = Just position - | otherwise = Nothing - -#test issue-6-pattern-linebreak-validity -## this is ugly, but at least syntactically valid. -foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do - (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String - -> IO Bool ) <- - ReflexHost.newExternalEvent - liftIO . forkIO . forever $ getLine >>= inputFire - ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent - -#test issue 16 -foldrDesc f z = unSwitchQueue $ \q -> - switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) - -#test issue 18 -autocheckCases = - [ ("Never Deadlocks" , representative deadlocksNever) - , ("No Exceptions" , representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative - ] - -#test issue 18b -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions" , representative exceptionsNever) - , ( "Consistent Result" - , alwaysSame -- already representative - ) - ] - -#test issue 18c -func = - [ (abc, (1111, 1111)) - , (def, (2, 2)) - , foo -- comment - ] - -#test issue 26 -foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - where g a b = b + b * a - -#test issue 26b -foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo - -#test aggressive alignment 1 -func = do - abc <- expr - abcccccccccccccccccc <- expr - abcccccccccccccccccccccccccccccccccccccccccc <- expr - abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr - -#test example alignment 1 -func (MyLongFoo abc def) = 1 -func (Bar a d ) = 2 -func _ = 3 - -#test listcomprehension-case-of -parserCompactLocation = - [ try - $ [ ParseRelAbs (Text.Read.read digits) _ _ - | digits <- many1 digit - , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe - [ case divPart of - Nothing -> Left $ Text.Read.read digits - Just ddigits -> - Right $ Text.Read.read digits % Text.Read.read ddigits - | digits <- many1 digit - , divPart <- optionMaybe (string "/" *> many1 digit) - ] - ] - ] - -#test opapp-specialcasing-1 -func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-2 -func = - fooooooooooooooooooooooooooooooooo - + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-3 -func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo - [ foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - ] - -#test opapp-indenting -parserPrim = - [ r - | r <- - [ SGPPrimFloat $ bool id (0 -) minus $ readGnok "parserPrim" - (d1 ++ d2 ++ d3 ++ d4) - | d2 <- string "." - , d3 <- many1 (oneOf "0123456789") - , _ <- string "f" - ] - <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "f" - ] - <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "i" - ] - ] - -#test another-parspacing-testcase - -samples = (SV.unpackaaaaadat) <&> \f -> - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -#test recordupd-singleline-bug - -runBrittany tabSize text = do - let config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text - -#test recordupd-singleline-bug-left - --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -runBrittany tabSize text = do - let - config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text - -#test issue 37 - -foo = - ( a - , -- comment1 - b - -- comment2 - , c - ) - -#test issue 38 - -{-# LANGUAGE TypeApplications #-} -foo = bar @Baz - -#test comment-before-BDCols -{-# LANGUAGE TypeApplications #-} -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do - docAlt - $ -- one-line solution - [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - | not hasComments - , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> [] - ] - ++ -- one-line solution + where in next line(s) - [ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] - ] - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - -#test comment-testcase-17 -{-# LANGUAGE MultiWayIf #-} -func = do - let foo = if - | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO - -> max - (defLen - 0.2) -- TODO - (defLen * 0.8) - | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO - return True - -#test issue 49 - -foo n = case n of - 1 -> True - -1 -> False - -bar n = case n of - (-2, -2) -> (-2, -2) - -#test issue 48 b - -{-# LANGUAGE TypeApplications #-} -foo = - let a = b @1 - cccc = () - in foo - -#test issue 52 a - -{-# LANGUAGE RecordWildCards #-} -v = A { a = 1, .. } where b = 2 - -#test issue 52 b - -{-# LANGUAGE RecordWildCards #-} -v = A { .. } where b = 2 - -#test issue 52 c - -{-# LANGUAGE RecordWildCards #-} -v = A { a = 1, b = 2, c = 3 } - -#test issue 63 a -test :: Proxy 'Int - -#test issue 63 b -test :: Proxy '[ 'True] - -#test issue 63 c -test :: Proxy '[Bool] - -#test issue 64 -{-# LANGUAGE RankNTypes, KindSignatures #-} -func - :: forall m str - . (Str str, Monad m) - => Int - -> Proxy (str :: [*]) - -> m (Tagged str String) - -#test issue 65 -widgetsDyn = - [ [ vBox - [ padTop Max outputLinesWidget - , padRight Max wid1 <+> flowWidget -- alignment here is strange/buggy - , padBottom (Pad 5) help - ] - ] - | wid1 <- promptDyn - , (flowWidget, _) <- flowResultD - , outputLinesWidget <- outputLinesWidgetD - , help <- suggestionHelpBox - , parser <- cmdParserD - ] - -#test issue 67 -fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b -fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) - - -#test parallellistcomp-workaround -cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] - -#test issue 70 -{-# LANGUAGE TemplateHaskell #-} -deriveFromJSON (unPrefix "assignPost") ''AssignmentPost - -#test issue 110 -main = -- a - let --b - x = 1 -- x - y = 2 -- y - in do - print x - print y - -#test issue 111 -alternatives :: Parser (Maybe Text) -alternatives = - alternativeOne -- first try this one - <|> alterantiveTwo -- then this one - <|> alternativeThree -- then this one - where - alternativeOne = purer "one" - alternativeTwo = purer "two" - alterantiveThree = purer "three" - -#test issue 116 -{-# LANGUAGE BangPatterns #-} -func = do - let !forced = some - pure () - -#test let-in-hanging -spanKey p q = case minViewWithKey q of - Just ((k, _), q') | p k -> - let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') - _ -> ([], q) - -#test issue 125 -a :: () ':- () - -#test issue 128 -func = do - createDirectoryIfMissing True path - openFile fileName AppendMode - -#test hspar-comments - -alternatives :: Parser (Maybe Text) -alternatives = -- a - ( -- b - alternativeOne -- c - <|> alterantiveTwo -- d - <|> alternativeThree -- e - ) -- f - -#test issue 133 -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall a - . () - => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -func - :: () - => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -#test alignment-potential-overflow -go l [] = Right l -go l ((IRType, _a) : eqr) = go l eqr -go l ((_, IRType) : eqr) = go l eqr -go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 -go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 - -#test issue 89 - type-family-instance -type instance XPure StageParse = () -type Pair a = (a, a) - -#test issue 144 --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = - let - eyuAfrarIso' - :: (RveoexdxunuAafalm -> Axlau (Axlau (a, OinejrdCplle))) - -> Gbodoy - -> Axlau (Axlau OinejrdCplle, Gbodoy) - eyuAfrarIso' = ulcPaaekBst cnehokzozwbVaguvu - amkgoxEhalazJjxunecCuIfaw - :: Axlau (Axlau OinejrdCplle, Gbodoy) -> Axlau RqlnrluYqednbCiggxi - amkgoxEhalazJjxunecCuIfaw uKqviuBisjtn = do - (sEmo, quc) <- uKqviuBisjtn - pure (xoheccewfWoeyiagOkfodiq sEmo quc) - xoheccewfWoeyiagOkfodiq - :: Axlau OinejrdCplle -> Gbodoy -> RqlnrluYqednbCiggxi - xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of - Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo - in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) - -#test issue 159 -spec = do - it "creates a snapshot at the given level" . withGraph runDB $ do - lift $ do - studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x - elaSnapshotReadingLevel snapshot `shouldBe` 12 - -#test non-bottom-specialcase-altsearch -jaicyhHumzo btrKpeyiFej mava = do - m :: VtohxeRgpmgsu <- qloxIfiq mava - case m of - ZumnaoFujayerIswadabo kkecm chlixxag -> do - imomue <- ozisduRaqiseSBAob btrKpeyiFej $ \s -> - case MizA.pigevo kkecm (_tc_gulawulu s) of - Ebocaba -> - ( s { _tc_gulawulu = MizA.jxariu kkecm rwuRqxzhjo (_tc_gulawulu s) } - , Gtzvonm - ) - Xcde{} -> (s, Pioemav) - pure imomue - -#test issue 214 --- brittany { lconfig_indentPolicy: IndentPolicyMultiple } -foo = bar - arg1 -- this is the first argument - arg2 -- this is the second argument - arg3 -- this is the third argument, now I'll skip one comment - arg4 - arg5 -- this is the fifth argument - arg6 -- this is the sixth argument - -#test issue 234 - -True `nand` True = False -nand _ _ = True - -nor False False = True -_ `nor` _ = False - -#test issue 256 prefix operator match - -f ((:) a as) = undefined - -#test issue 228 lambda plus lazy or bang pattern - -{-# LANGUAGE BangPatterns #-} -a = \x -> x -b = \ ~x -> x -c = \ !x -> x -d = \(~x) -> x - -#test type signature with forall and constraint -{-# LANGUAGE RankNTypes #-} -func :: forall b . Show b => b -> String - -#test issue 267 - -{-# LANGUAGE TypeFamilies #-} -f :: ((~) a b) => a -> b -f = id - -#test large record update --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -vakjkeSulxudbFokvir = Duotpo - { _ekku_gcrpbze = xgonae (1 :: Int) - , _oola_louwu = FoqsiYcuidx - { _xxagu_umea_iaztoj = xgonae False - , _tuktg_tizo_kfikacygsqf = xgonae False - , _ahzbo_xpow_otq_nzeyufq = xgonae False - , _uagpi_lzps_luy_xcjn = xgonae False - , _dxono_qjef_aqtafq_bes = xgonae False - , _yzuaf_nviy_vuhwxe_ihnbo_uhw = xgonae False - , _iwcit_fzjs_yerakt_dicox_mtryitko = xgonae False - , _ehjim_ucfe_dewarp_newrt_gso = xgonae False - , _ogtxb_ivoj_amqgai_rttui_xuwhetb = xgonae False - , _bhycb_iexz_megaug_qunoa_ohaked = xgonae False - , _nnmbe_uqgt_ewsuga_vaiis = xgonae False - , _otzil_ucvugaiyj_aosoiatunx_asir = xgonae False - } - , _iwsc_lalojz = XqspaiDainqw - { _uajznac_ugah = xgonae (80 :: Int) - , _qayziku_gazibzDejipj = xgonae DewizeCxwgyiKjig - , _auhebll_fiqjxyArfxia = xgonae (2 :: Int) - , _zubfuhq_dupiwnIoophXameeet = xgonae True - , _oavnuqg_opkreyOufuIkifiin = xgonae True - , _ufojfwy_fhuzcePeqwfu = xgonae (50 :: Int) - , _mlosikq_zajdxxSeRoelpf = xgonae (50 :: Int) - , _heemavf_fjgOfoaikh = xgonae (FyoVfvdygaZuzuvbeWarwuq 3) - , _ohxmeoq_ogtbfoPtqezVseu = xgonae (EdjotoLcbapUdiuMmytwoig 0.7) - , _omupuiu_ituamexjuLccwu = xgonae (30 :: Int) - , _xoseksf_atvwwdwaoHanofMyUvujjopoz = xgonae True - , _umuuuat_nuamezwWeqfUqzrnaxwp = xgonae False - , _uuriguz_wixhutbuKecigaFiwosret = xgonae True - , _betohxp_scixaLsvcesErtwItxrnaJmuz = xgonae False - , _lchxgee_olaetGcqzuqxVujenCzexub = xgonae True - , _egeibao_imamkuigqikhZdcbpidokVcixiqew = xgonae False - } - , _nloo_cfmrgZcisiugk = YuwodSavxwnicBekuel - { _oebew_rrtpvthUzlizjAqIwesly = xgonae False - , _blkff_Acxoid = xgonae False - , _datei_YewolAowoqOpunvpgu = xgonae BeekgUzojaPnixxaruJehyPmnnfu - , _ejfrj_eheb_justvh_pumcp_ismya = xgonae False - } - , _kena_uzeddovosoki = NyoRvshullezUpauud - { _mtfuwi_TUVEmoi = xgonae RZXKoytUtogx - , _larqam_adaxPehaylZafeqgpc = xgonae False - } - , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } - , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False - , _qaqb_eykzuyuwi = xgonae False - -- test comment - } - -#test large record wildcard comment - --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -vakjkeSulxudbFokvir = Duotpo - { _ekku_gcrpbze = xgonae (1 :: Int) - , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } - , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False - , _qaqb_eykzuyuwi = xgonae False - -- test comment - , -- N.B. - .. -- x - } - -#test issue 263 - -func = abc + def - -- a - -- b - - -- comment - - where - abc = 13 - def = 1 - -#test AddBaseY/EnsureIndent float in effect - -zItazySunefp twgq nlyo lwojjoBiecao = - let mhIarjyai = - ukwAausnfcn - $ XojlsTOSR.vuwOvuvdAZUOJaa - $ XojlsTOSR.vkesForanLiufjeDI - $ XojlsTOSR.vkesForanLiufjeDI - $ XojlsTOSR.popjAyijoWarueeP - $ XojlsTOSR.jpwuPmafuDqlbkt nlyo - $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng - $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow - $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) - $ etOslnoz lwojjoBiecao - in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) - -#test module initial comment --- test -module MyModule where - -#test issue 231 - -foo = - [ ("xxx", "xx") - , -- - ("xx" , "xx") - -- - , ("xx" , "xxxxx") - , ("xx" , "xx") - ] - -#test issue 231 not - -foo = - [ ("xx", "xx") - , ( "xx" -- - , "xx" - ) - , ("xx", "xxxxx") - , ("xx", "xx") - ] - -#test issue 281 - -module Main - ( DataTypeI - , DataTypeII(DataConstructor) - -- * Haddock heading - , name - ) where - -#test type level list - -xeoeqibIaib - :: ( KqujhIsaus m - , XivuvIpoboi Droqifim m - , IgorvOtowtf m - , RyagaYaqac m - , QouruDU m - ) - => MaptAdfuxgu - -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd - -> QNOZqwuzg - -> Eoattuq - '[ XkatytdWdquraosu -- test comment - , KyezKijim -- another test comment - , DjmioeePuoeg - , NinrxoiOwezc - , QATAlrijacpk - , TrutvotwIwifiqOjdtu - , CoMmuatjwr - , BoZckzqyodseZole - , VagfwoXaeChfqe - ] - m - () - -#test recordupd-overflow-bad-multiline-spacing - -createRedirectedProcess processConfig = do - let redirectedProc = (_processConfig_inner processConfig) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - foo - -#test issue 282 - -instance HasDependencies SomeDataModel where - -- N.B. Here is a bunch of explanatory context about the relationship - -- between these data models or whatever. - type Dependencies SomeDataModel - = (SomeOtherDataModelId, SomeOtherOtherDataModelId) - -#test stupid-do-operator-combination - -func = - do - y - >>= x diff --git a/data/16-pending.blt b/data/16-pending.blt deleted file mode 100644 index c8147d8..0000000 --- a/data/16-pending.blt +++ /dev/null @@ -1,35 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group pending -############################################################################### -############################################################################### -############################################################################### - - - -## this testcase is not about idempotency, but about _how_ the output differs -## from the input; i cannot really express this yet with the current -## test-suite. -## #test ayaz -## -## myManageHook = -## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] -## <+> composeAll -## [ className =? "Pidgin" --> doFloat -## , className =? "XCalc" --> doFloat -## -- plan9port's acme -## , className =? "acme" --> doFloat -## -- Acme with Vi bindings editor -## , title =? "ED" --> doFloat -## , title =? "wlc-x11" --> doFloat -## , className =? "Skype" --> doFloat -## , className =? "ffplay" --> doFloat -## , className =? "mpv" --> doFloat -## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc. -## -- Firefox works well tiled, but it has dialog windows we want to float. -## , appName =? "Browser" --> doFloat -## ] -## where -## role = stringProperty "WM_WINDOW_ROLE" - diff --git a/data/30-tests-context-free.blt b/data/30-tests-context-free.blt deleted file mode 100644 index d73e6d4..0000000 --- a/data/30-tests-context-free.blt +++ /dev/null @@ -1,1461 +0,0 @@ - -############################################################################### -############################################################################### -############################################################################### -#group type signatures -############################################################################### -############################################################################### -############################################################################### - -#test simple001 -func :: a -> a - -#test long typeVar -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -#test keep linebreak mode -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - -#test simple parens 1 -func :: ((a)) - -#test simple parens 2 -func :: (a -> a) -> a - -#test simple parens 3 -func :: a -> (a -> a) - -#test did anyone say parentheses? -func :: (((((((((()))))))))) - --- current output is.. funny. wonder if that can/needs to be improved.. -#test give me more! -#pending nested tuples over line length -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 HsOpTy -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 --- 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 -func = f - where - {-# INLINE [~1] f #-} - f = id - - -############################################################################### -############################################################################### -############################################################################### -#group data type declarations -############################################################################### -############################################################################### -############################################################################### - -#test single record -data Foo = Bar - { foo :: Baz - } - -#test record multiple names -data Foo = Bar - { foo, bar :: Baz - } - -#test record multiple types -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - -#test record multiple types and names -data Foo = Bar - { foo, biz :: Baz - , bar :: Bizzz - } - -#test record multiple types deriving -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - deriving Show - -#test record multiple types deriving -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) - - -############################################################################### -############################################################################### -############################################################################### -#group equation.basic -############################################################################### -############################################################################### -############################################################################### -## some basic testing of different kinds of equations. -## some focus on column layouting for multiple-equation definitions. -## (that part probably is not implemented in any way yet.) - -#test basic 1 -func x = x - -#test infix 1 -x *** y = x - -#test symbol prefix -(***) x y = x - - -############################################################################### -############################################################################### -############################################################################### -#group equation.patterns -############################################################################### -############################################################################### -############################################################################### - -#test wildcard -func _ = x - -#test simple long pattern -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = - x - -#test simple multiline pattern -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x - -#test another multiline pattern -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b - = x - -#test simple constructor -func (A a) = a - -#test list constructor -func (x : xr) = x - -#test some other constructor symbol -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 -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test long keep linemode 1 -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - -#test long keep linemode 2 -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 -func = - ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - ) - -#test let in on single line -foo = - let longIdentifierForShortValue = 1 - in longIdentifierForShortValue + longIdentifierForShortValue - - - -############################################################################### -############################################################################### -############################################################################### -#group expression.do statements -############################################################################### -############################################################################### -############################################################################### - -#test simple -func = do - stmt - stmt - -#test bind -func = do - x <- stmt - stmt x - -#test let -func = do - let x = 13 - stmt x - - -############################################################################### -############################################################################### -############################################################################### -#group expression.lists -############################################################################### -############################################################################### -############################################################################### - -#test monad-comprehension-case-of -func = - foooooo - $ [ case - foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - of - _ -> True - ] - - -############################################################################### -############################################################################### -############################################################################### -#group expression.multiwayif -############################################################################### -############################################################################### -############################################################################### - -#test simple -{-# LANGUAGE MultiWayIf #-} -func = if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - -#test simplenested -{-# LANGUAGE MultiWayIf #-} -func = do - foo - bar $ if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 - - -############################################################################### -############################################################################### -############################################################################### -#group stylisticspecialcases -############################################################################### -############################################################################### -############################################################################### - -#test operatorprefixalignment-even-with-multiline-alignbreak -func = - foo - $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - ] - ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] - -############################################################################### -############################################################################### -############################################################################### -#group module -############################################################################### -############################################################################### -############################################################################### - -#test simple -module Main where - -#test no-exports -module Main () where - -#test one-export -module Main (main) where - -#test several-exports -module Main (main, test1, test2) where - -#test many-exports -module Main - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) where - -#test exports-with-comments -module Main - ( main - -- main - , test1 - , test2 - -- Test 3 - , test3 - , test4 - -- Test 5 - , test5 - -- Test 6 - ) where - -#test simple-export-with-things -module Main (Test(..)) where - -#test simple-export-with-module-contents -module Main (module Main) where - -#test export-with-things -module Main (Test(Test, a, b)) where - -#test export-with-empty-thing -module Main (Test()) where - -#test empty-with-comment --- Intentionally left empty - -############################################################################### -############################################################################### -############################################################################### -#group import -############################################################################### -############################################################################### -############################################################################### - -#test simple-import -import Data.List - -#test simple-import-alias -import Data.List as L - -#test simple-qualified-import -import qualified Data.List - -#test simple-qualified-import-alias -import qualified Data.List as L - -#test simple-safe -import safe Data.List as L - -#test simple-source -import {-# SOURCE #-} Data.List () - -#test simple-safe-qualified -import safe qualified Data.List hiding (nub) - -#test simple-safe-qualified-source -import {-# SOURCE #-} safe qualified Data.List - -#test simple-qualified-package -import qualified "base" Data.List - -#test qualifier-effect -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List () -import {-# SOURCE #-} safe qualified Data.List hiding () - -#test instances-only -import qualified Data.List () - -#test one-element -import Data.List (nub) - -#test several-elements -import Data.List (foldl', indexElem, nub) - -#test a-ridiculous-amount-of-elements -import Test - ( Long - , anymore - , fit - , items - , line - , list - , not - , onA - , quite - , single - , that - , will - , with - ) - -#test with-things -import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>))) - -#test hiding -import Test hiding () -import Test as T hiding () - -#test import-hiding-many -import Prelude as X - hiding - ( head - , init - , last - , maximum - , minimum - , pred - , read - , readFile - , succ - , tail - , undefined - ) - -#test long-module-name-simple -import MoreThanSufficientlyLongModuleNameWithSome - (compact, fit, inA, items, layout, not, that, will) -import TestJustAbitToLongModuleNameLikeThisOneIs () -import TestJustShortEnoughModuleNameLikeThisOne () - -#test long-module-name-as -import TestJustAbitToLongModuleNameLikeThisOneI as T -import TestJustShortEnoughModuleNameLikeThisOn as T - -#test long-module-name-hiding -import TestJustAbitToLongModuleNameLikeTh hiding () -import TestJustShortEnoughModuleNameLike hiding () - -#test long-module-name-simple-items -import MoreThanSufficientlyLongModuleNameWithSome - (compact, fit, inA, items, layout, not, that, will) - -#test long-module-name-hiding-items -import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) - -#test import-with-comments --- Test -import Data.List (nub) -- Test -{- Test -} -import qualified Data.List as L (foldl') {- Test -} - -#test import-with-comments-2 - -import Test - ( abc - , def - -- comment - ) - -#test import-with-comments-3 - -import Test - ( abc - -- comment - ) - -#test import-with-comments-4 -import Test - ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) - --- Test -import Test (test) - -#test import-with-comments-5 -import Test - ( -- comment - ) - -#test long-bindings -import Test (longbindingNameThatoverflowsColum) -import Test (Long(List, Of, Things)) - -#test things-with-with-comments -import Test - ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) -import Test - ( Thing - ( Item - -- and Comment - ) - ) -import Test - ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) - -#test prefer-dense-empty-list -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine - () - -#test preamble full-preamble -{-# LANGUAGE BangPatterns #-} - -{- - - Test module - -} -module Test - ( test1 - -- ^ test - , test2 - -- | test - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - ) where - --- Test -import Data.List (nub) -- Test -{- Test -} -import qualified Data.List as L (foldl') {- Test -} - --- Test -import Test (test) - -############################################################################### -############################################################################### -############################################################################### -#group regression -############################################################################### -############################################################################### -############################################################################### - -#test newlines-comment -func = do - abc <- foo - ---abc -return () - -#test parenthesis-around-unit -func = (()) - -#test let-defs indentation -func = do - let - foo True = True - foo _ = False - return () - -#test let-defs no indent -func = do - let - foo True = True - foo _ = False - return () - -#test let-defs no indent -func = do - let - foo = True - b = False - return () - -#test let-defs no indent -func = - let - foo = True - b = False - in return () - -#test record update indentation 1 -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } - -#test record update indentation 2 -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent state - , _lstate_foo = _lstate_foo state - } - -#test record update indentation 3 -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo kasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 1 -func = Foo { _lstate_indent = _lstate_indent state } - -#test record construction 2 -func = Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test record construction 3 -func = do - Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } - -#test post-indent comment -func = do --- abc - -- def - return () - -#test post-unindent comment -func = do - do - return () - -- abc - -- def - return () - -#test CPP empty comment case -#pending CPP parsing needs fixing for roundTripEqual -{-# LANGUAGE CPP #-} -module Test where -func = do -#if FOO - let x = 13 -#endif - stmt x - -## really, the following should be handled by forcing the Alt to multiline -## because there are comments. as long as this is not implemented though, -## we should ensure the trivial solution works. -#test comment inline placement (temporary) -func - :: Int -- basic indentation amount - -> Int -- currently used width in current line (after indent) - -- used to accurately calc placing of the current-line - -> LayoutDesc - -> Int - -#test some indentation thingy -func = - (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj - $ abc - $ def - $ ghi - $ jkl - ) - -#test parenthesized operator -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where reassoc (v, e, w) = (v, (e, w)) - -#test record pattern matching stuff -downloadRepoPackage = case repo of - RepoLocal {..} -> return () - RepoLocal { abc } -> return () - RepoLocal{} -> return () - -#test do let comment indentation level problem -func = do - let - (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' - -- default local dir target if there's no given target - utargets'' = "foo" - return () - -#test list comprehension comment placement -func = - [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_ : _)) <- nosuchFooThing - , gast <- award - ] - -#test if-then-else comment placement -func = if x - then if y -- y is important - then foo - else bar - else Nothing - -#test qualified infix pattern -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR - -#test type signature multiline forcing issue -layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () - -#test multiwayif proper indentation -{-# LANGUAGE MultiWayIf #-} -readMergePersConfig path shouldCreate conf = do - exists <- liftIO $ System.Directory.doesFileExist path - if - | exists -> do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn e - mzero - Right x -> return x - return $ fileConf Semigroup.<> conf - | shouldCreate -> do - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) - staticDefaultConfig - return $ conf - | otherwise -> do - return conf - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _) -> InstallOk - -#test nested pattern alignment issue" -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _) -> InstallOk - -#test partially overflowing alignment issue" -showPackageDetailedInfo pkginfo = - renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) - $ char '*' - $+$ something - [ entry "Synopsis" synopsis hideIfNull reflowParagraphs - , entry - "Versions available" - sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry - "Versions installed" - installedVersions - (altText - null - (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") - ) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description hideIfNull reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) - then empty - else text "Modules:" - $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ] - -#test issue 7a -isValidPosition position - | validX && validY = Just position - | otherwise = Nothing - -#test issue-6-pattern-linebreak-validity -## this is ugly, but at least syntactically valid. -foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do - (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String - -> IO Bool) <- - ReflexHost.newExternalEvent - liftIO . forkIO . forever $ getLine >>= inputFire - ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent - -#test issue 15 --- Test.hs -module Test where - -data X = X - -#test issue 16 -foldrDesc f z = unSwitchQueue $ \q -> - switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) - -#test issue 18 -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative - ] - -#test issue 18b -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ( "Consistent Result" - , alwaysSame -- already representative - ) - ] - -#test issue 18c -func = - [ (abc, (1111, 1111)) - , (def, (2, 2)) - , foo -- comment - ] - -#test issue 26 -foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - where g a b = b + b * a - -#test issue 26b -foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo - -#test aggressive alignment 1 -func = do - abc <- expr - abcccccccccccccccccc <- expr - abcccccccccccccccccccccccccccccccccccccccccc <- expr - abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr - -#test example alignment 1 -func (MyLongFoo abc def) = 1 -func (Bar a d) = 2 -func _ = 3 - -#test listcomprehension-case-of -parserCompactLocation = - [ try - $ [ ParseRelAbs (Text.Read.read digits) _ _ - | digits <- many1 digit - , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe - [ case divPart of - Nothing -> Left $ Text.Read.read digits - Just ddigits -> - Right $ Text.Read.read digits % Text.Read.read ddigits - | digits <- many1 digit - , divPart <- optionMaybe (string "/" *> many1 digit) - ] - ] - ] - -#test opapp-specialcasing-1 -func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-2 -func = - fooooooooooooooooooooooooooooooooo - + foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - -#test opapp-specialcasing-3 -func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo - [ foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - ] - -#test opapp-indenting -parserPrim = - [ r - | r <- - [ SGPPrimFloat $ bool id (0 -) minus $ readGnok - "parserPrim" - (d1 ++ d2 ++ d3 ++ d4) - | d2 <- string "." - , d3 <- many1 (oneOf "0123456789") - , _ <- string "f" - ] - <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "f" - ] - <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "i" - ] - ] - -#test another-parspacing-testcase - -samples = (SV.unpackaaaaadat) <&> \f -> - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -#test recordupd-singleline-bug - -runBrittany tabSize text = do - let - config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text - -#test issue 38 - -{-# LANGUAGE TypeApplications #-} -foo = bar @Baz - -#test comment-before-BDCols -{-# LANGUAGE TypeApplications #-} -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do - docAlt - $ -- one-line solution - [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - | not hasComments - , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> [] - ] - ++ -- one-line solution + where in next line(s) - [ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] - ] - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] - -#test comment-testcase-17 -{-# LANGUAGE MultiWayIf #-} -func = do - let - foo = if - | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO - -> max - (defLen - 0.2) -- TODO - (defLen * 0.8) - | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO - return True - -#test issue 49 - -foo n = case n of - 1 -> True - -1 -> False - -bar n = case n of - (-2, -2) -> (-2, -2) - -#test issue 48 b - -{-# LANGUAGE TypeApplications #-} -foo = - let - a = b @1 - cccc = () - in foo - -#test issue 176 - -record :: Record -record = Record - { rProperties = - [ "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - ] - } - - -############################################################################### -############################################################################### -############################################################################### -#group pending -############################################################################### -############################################################################### -############################################################################### - - - -## this testcase is not about idempotency, but about _how_ the output differs -## from the input; i cannot really express this yet with the current -## test-suite. -## #test ayaz -## -## myManageHook = -## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] -## <+> composeAll -## [ className =? "Pidgin" --> doFloat -## , className =? "XCalc" --> doFloat -## -- plan9port's acme -## , className =? "acme" --> doFloat -## -- Acme with Vi bindings editor -## , title =? "ED" --> doFloat -## , title =? "wlc-x11" --> doFloat -## , className =? "Skype" --> doFloat -## , className =? "ffplay" --> doFloat -## , className =? "mpv" --> doFloat -## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc. -## -- Firefox works well tiled, but it has dialog windows we want to float. -## , appName =? "Browser" --> doFloat -## ] -## where -## role = stringProperty "WM_WINDOW_ROLE" diff --git a/data/40-indent-policy-multiple.blt b/data/40-indent-policy-multiple.blt deleted file mode 100644 index b75c726..0000000 --- a/data/40-indent-policy-multiple.blt +++ /dev/null @@ -1,42 +0,0 @@ -############################################################################### -############################################################################### -############################################################################### -#group indent-policy-multiple -############################################################################### -############################################################################### -############################################################################### - -#test long --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - -#test let indAmount=4 --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo - -#test let indAmount=8 --- brittany { lconfig_indentAmount: 8, lconfig_indentPolicy: IndentPolicyMultiple } -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo - -#test nested do-block --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -foo = asdyf8asdf - "ajsdfas" - [ asjdf asyhf $ do - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ] diff --git a/data/Test1.hs b/data/Test1.hs new file mode 100644 index 0000000..44e6262 --- /dev/null +++ b/data/Test1.hs @@ -0,0 +1 @@ +func :: a -> a diff --git a/data/Test10.hs b/data/Test10.hs new file mode 100644 index 0000000..f1b8e0d --- /dev/null +++ b/data/Test10.hs @@ -0,0 +1,3 @@ +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) diff --git a/data/Test100.hs b/data/Test100.hs new file mode 100644 index 0000000..f6643c0 --- /dev/null +++ b/data/Test100.hs @@ -0,0 +1 @@ +func = klajsdas klajsdas klajsdas diff --git a/data/Test101.hs b/data/Test101.hs new file mode 100644 index 0000000..57bac0e --- /dev/null +++ b/data/Test101.hs @@ -0,0 +1,3 @@ +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd diff --git a/data/Test102.hs b/data/Test102.hs new file mode 100644 index 0000000..b361b53 --- /dev/null +++ b/data/Test102.hs @@ -0,0 +1,3 @@ +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas + lakjsdlajsdljas + lakjsdlajsdljas diff --git a/data/Test103.hs b/data/Test103.hs new file mode 100644 index 0000000..2b2b052 --- /dev/null +++ b/data/Test103.hs @@ -0,0 +1 @@ +func = (1 +) diff --git a/data/Test104.hs b/data/Test104.hs new file mode 100644 index 0000000..e8f99be --- /dev/null +++ b/data/Test104.hs @@ -0,0 +1 @@ +func = (+ 1) diff --git a/data/Test105.hs b/data/Test105.hs new file mode 100644 index 0000000..699ead3 --- /dev/null +++ b/data/Test105.hs @@ -0,0 +1 @@ +func = (1 `abc`) diff --git a/data/Test106.hs b/data/Test106.hs new file mode 100644 index 0000000..ccaa551 --- /dev/null +++ b/data/Test106.hs @@ -0,0 +1 @@ +func = (`abc` 1) diff --git a/data/Test107.hs b/data/Test107.hs new file mode 100644 index 0000000..99b30ec --- /dev/null +++ b/data/Test107.hs @@ -0,0 +1 @@ +func = (abc, def) diff --git a/data/Test108.hs b/data/Test108.hs new file mode 100644 index 0000000..90f6d90 --- /dev/null +++ b/data/Test108.hs @@ -0,0 +1 @@ +func = (abc, ) diff --git a/data/Test109.hs b/data/Test109.hs new file mode 100644 index 0000000..973aed0 --- /dev/null +++ b/data/Test109.hs @@ -0,0 +1 @@ +func = (, abc) diff --git a/data/Test11.hs b/data/Test11.hs new file mode 100644 index 0000000..25670eb --- /dev/null +++ b/data/Test11.hs @@ -0,0 +1,3 @@ +func + :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) + -> lakjsdlkjasldkj diff --git a/data/Test110.hs b/data/Test110.hs new file mode 100644 index 0000000..78d0c01 --- /dev/null +++ b/data/Test110.hs @@ -0,0 +1,6 @@ +myTupleSection = + ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement + , + , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement + , + ) diff --git a/data/Test111.hs b/data/Test111.hs new file mode 100644 index 0000000..87acbec --- /dev/null +++ b/data/Test111.hs @@ -0,0 +1,4 @@ +func = + ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + ) diff --git a/data/Test112.hs b/data/Test112.hs new file mode 100644 index 0000000..daf62d6 --- /dev/null +++ b/data/Test112.hs @@ -0,0 +1,6 @@ +foo = if True + then + -- iiiiii + "a " + else + "b " diff --git a/data/Test113.hs b/data/Test113.hs new file mode 100644 index 0000000..26bb39d --- /dev/null +++ b/data/Test113.hs @@ -0,0 +1,5 @@ +func = if cond + then pure 42 + else do + -- test + abc diff --git a/data/Test114.hs b/data/Test114.hs new file mode 100644 index 0000000..ea9f935 --- /dev/null +++ b/data/Test114.hs @@ -0,0 +1,3 @@ +func = case x of + False -> False + True -> True diff --git a/data/Test115.hs b/data/Test115.hs new file mode 100644 index 0000000..eb88667 --- /dev/null +++ b/data/Test115.hs @@ -0,0 +1,7 @@ +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True diff --git a/data/Test116.hs b/data/Test116.hs new file mode 100644 index 0000000..5d7739c --- /dev/null +++ b/data/Test116.hs @@ -0,0 +1,7 @@ +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of + False -> False + True -> True diff --git a/data/Test117.hs b/data/Test117.hs new file mode 100644 index 0000000..43e6130 --- /dev/null +++ b/data/Test117.hs @@ -0,0 +1 @@ +func = case x of {} diff --git a/data/Test118.hs b/data/Test118.hs new file mode 100644 index 0000000..85c98c6 --- /dev/null +++ b/data/Test118.hs @@ -0,0 +1,5 @@ +func = + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} diff --git a/data/Test119.hs b/data/Test119.hs new file mode 100644 index 0000000..195201e --- /dev/null +++ b/data/Test119.hs @@ -0,0 +1,5 @@ +func = do + case + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + of {} diff --git a/data/Test12.hs b/data/Test12.hs new file mode 100644 index 0000000..fa012f7 --- /dev/null +++ b/data/Test12.hs @@ -0,0 +1,5 @@ +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> lakjsdlkjasldkj diff --git a/data/Test120.hs b/data/Test120.hs new file mode 100644 index 0000000..5bbd0e6 --- /dev/null +++ b/data/Test120.hs @@ -0,0 +1,3 @@ +func = do + stmt + stmt diff --git a/data/Test121.hs b/data/Test121.hs new file mode 100644 index 0000000..aa47dfd --- /dev/null +++ b/data/Test121.hs @@ -0,0 +1,3 @@ +func = do + x <- stmt + stmt x diff --git a/data/Test122.hs b/data/Test122.hs new file mode 100644 index 0000000..589d354 --- /dev/null +++ b/data/Test122.hs @@ -0,0 +1,3 @@ +func = do + let x = 13 + stmt x diff --git a/data/Test123.hs b/data/Test123.hs new file mode 100644 index 0000000..6319013 --- /dev/null +++ b/data/Test123.hs @@ -0,0 +1,7 @@ +func = + foooooo + $ [ case + foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + of + _ -> True + ] diff --git a/data/Test124.hs b/data/Test124.hs new file mode 100644 index 0000000..1164c0f --- /dev/null +++ b/data/Test124.hs @@ -0,0 +1,4 @@ +testMethod foo bar baz qux = + let x = undefined foo bar baz qux qux baz bar :: String + -- some comment explaining the in expression + in undefined foo x :: String diff --git a/data/Test125.hs b/data/Test125.hs new file mode 100644 index 0000000..e711480 --- /dev/null +++ b/data/Test125.hs @@ -0,0 +1,4 @@ +testMethod foo bar baz qux = + let x = undefined :: String + -- some comment explaining the in expression + in undefined :: String diff --git a/data/Test126.hs b/data/Test126.hs new file mode 100644 index 0000000..e0c379a --- /dev/null +++ b/data/Test126.hs @@ -0,0 +1,3 @@ +testMethod foo bar baz qux = + -- some comment explaining the in expression + let x = undefined :: String in undefined :: String diff --git a/data/Test127.hs b/data/Test127.hs new file mode 100644 index 0000000..e446394 --- /dev/null +++ b/data/Test127.hs @@ -0,0 +1,6 @@ +foo foo bar baz qux = + let a = 1 + b = 2 + c = 3 + -- some comment explaining the in expression + in undefined :: String diff --git a/data/Test128.hs b/data/Test128.hs new file mode 100644 index 0000000..8e3a783 --- /dev/null +++ b/data/Test128.hs @@ -0,0 +1,6 @@ +func = + foo + $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + ] + ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] diff --git a/data/Test129.hs b/data/Test129.hs new file mode 100644 index 0000000..6ca9a1f --- /dev/null +++ b/data/Test129.hs @@ -0,0 +1 @@ +module Main where diff --git a/data/Test13.hs b/data/Test13.hs new file mode 100644 index 0000000..68e8e9e --- /dev/null +++ b/data/Test13.hs @@ -0,0 +1,5 @@ +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test130.hs b/data/Test130.hs new file mode 100644 index 0000000..43a1fee --- /dev/null +++ b/data/Test130.hs @@ -0,0 +1 @@ +module Main () where diff --git a/data/Test131.hs b/data/Test131.hs new file mode 100644 index 0000000..0fdcb21 --- /dev/null +++ b/data/Test131.hs @@ -0,0 +1 @@ +module Main (main) where diff --git a/data/Test132.hs b/data/Test132.hs new file mode 100644 index 0000000..1998fe9 --- /dev/null +++ b/data/Test132.hs @@ -0,0 +1 @@ +module Main (main, test1, test2) where diff --git a/data/Test133.hs b/data/Test133.hs new file mode 100644 index 0000000..20fd443 --- /dev/null +++ b/data/Test133.hs @@ -0,0 +1,12 @@ +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) where diff --git a/data/Test134.hs b/data/Test134.hs new file mode 100644 index 0000000..20ea610 --- /dev/null +++ b/data/Test134.hs @@ -0,0 +1,12 @@ +module Main + ( main + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) where diff --git a/data/Test135.hs b/data/Test135.hs new file mode 100644 index 0000000..6d7b8eb --- /dev/null +++ b/data/Test135.hs @@ -0,0 +1 @@ +module Main (Test(..)) where diff --git a/data/Test136.hs b/data/Test136.hs new file mode 100644 index 0000000..e06cbfc --- /dev/null +++ b/data/Test136.hs @@ -0,0 +1 @@ +module Main (module Main) where diff --git a/data/Test137.hs b/data/Test137.hs new file mode 100644 index 0000000..5f1af50 --- /dev/null +++ b/data/Test137.hs @@ -0,0 +1 @@ +module Main (Test(Test, a, b)) where diff --git a/data/Test138.hs b/data/Test138.hs new file mode 100644 index 0000000..b436099 --- /dev/null +++ b/data/Test138.hs @@ -0,0 +1,6 @@ +-- comment1 +module Main + ( Test(Test, a, b) + , foo -- comment2 + ) -- comment3 + where diff --git a/data/Test139.hs b/data/Test139.hs new file mode 100644 index 0000000..6fd114e --- /dev/null +++ b/data/Test139.hs @@ -0,0 +1 @@ +module Main (Test()) where diff --git a/data/Test14.hs b/data/Test14.hs new file mode 100644 index 0000000..05b4cb6 --- /dev/null +++ b/data/Test14.hs @@ -0,0 +1 @@ +func :: asd -> Either a b diff --git a/data/Test140.hs b/data/Test140.hs new file mode 100644 index 0000000..6d7a6ef --- /dev/null +++ b/data/Test140.hs @@ -0,0 +1 @@ +-- Intentionally left empty diff --git a/data/Test141.hs b/data/Test141.hs new file mode 100644 index 0000000..a053bb5 --- /dev/null +++ b/data/Test141.hs @@ -0,0 +1 @@ +import Data.List diff --git a/data/Test142.hs b/data/Test142.hs new file mode 100644 index 0000000..1bc9f03 --- /dev/null +++ b/data/Test142.hs @@ -0,0 +1 @@ +import Data.List as L diff --git a/data/Test143.hs b/data/Test143.hs new file mode 100644 index 0000000..691c0c1 --- /dev/null +++ b/data/Test143.hs @@ -0,0 +1 @@ +import qualified Data.List diff --git a/data/Test144.hs b/data/Test144.hs new file mode 100644 index 0000000..b64f22f --- /dev/null +++ b/data/Test144.hs @@ -0,0 +1 @@ +import qualified Data.List as L diff --git a/data/Test145.hs b/data/Test145.hs new file mode 100644 index 0000000..020afa7 --- /dev/null +++ b/data/Test145.hs @@ -0,0 +1 @@ +import safe Data.List as L diff --git a/data/Test146.hs b/data/Test146.hs new file mode 100644 index 0000000..cad516e --- /dev/null +++ b/data/Test146.hs @@ -0,0 +1 @@ +import {-# SOURCE #-} Data.List ( ) diff --git a/data/Test147.hs b/data/Test147.hs new file mode 100644 index 0000000..42148e0 --- /dev/null +++ b/data/Test147.hs @@ -0,0 +1 @@ +import safe qualified Data.List diff --git a/data/Test148.hs b/data/Test148.hs new file mode 100644 index 0000000..dd2c6b9 --- /dev/null +++ b/data/Test148.hs @@ -0,0 +1 @@ +import {-# SOURCE #-} safe qualified Data.List diff --git a/data/Test149.hs b/data/Test149.hs new file mode 100644 index 0000000..650a6ad --- /dev/null +++ b/data/Test149.hs @@ -0,0 +1 @@ +import qualified "base" Data.List diff --git a/data/Test15.hs b/data/Test15.hs new file mode 100644 index 0000000..668dca4 --- /dev/null +++ b/data/Test15.hs @@ -0,0 +1,5 @@ +func + :: asd + -> Either + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test150.hs b/data/Test150.hs new file mode 100644 index 0000000..0c30830 --- /dev/null +++ b/data/Test150.hs @@ -0,0 +1,3 @@ +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List ( ) +import {-# SOURCE #-} safe qualified Data.List hiding ( ) diff --git a/data/Test151.hs b/data/Test151.hs new file mode 100644 index 0000000..992b081 --- /dev/null +++ b/data/Test151.hs @@ -0,0 +1 @@ +import qualified Data.List ( ) diff --git a/data/Test152.hs b/data/Test152.hs new file mode 100644 index 0000000..631bb4c --- /dev/null +++ b/data/Test152.hs @@ -0,0 +1 @@ +import Data.List ( nub ) diff --git a/data/Test153.hs b/data/Test153.hs new file mode 100644 index 0000000..537fce6 --- /dev/null +++ b/data/Test153.hs @@ -0,0 +1,4 @@ +import Data.List ( foldl' + , indexElem + , nub + ) diff --git a/data/Test154.hs b/data/Test154.hs new file mode 100644 index 0000000..387f268 --- /dev/null +++ b/data/Test154.hs @@ -0,0 +1,14 @@ +import Test ( Long + , anymore + , fit + , items + , line + , list + , not + , onA + , quite + , single + , that + , will + , with + ) diff --git a/data/Test155.hs b/data/Test155.hs new file mode 100644 index 0000000..6150ff3 --- /dev/null +++ b/data/Test155.hs @@ -0,0 +1,11 @@ +import Test ( (+) + , (:!)(..) + , (:*)((:.), T7, t7) + , (:.) + , T + , T2() + , T3(..) + , T4(T4) + , T5(T5, t5) + , T6((<|>)) + ) diff --git a/data/Test156.hs b/data/Test156.hs new file mode 100644 index 0000000..9eb3db5 --- /dev/null +++ b/data/Test156.hs @@ -0,0 +1,3 @@ +import Test hiding ( ) +import Test as T + hiding ( ) diff --git a/data/Test157.hs b/data/Test157.hs new file mode 100644 index 0000000..f78c007 --- /dev/null +++ b/data/Test157.hs @@ -0,0 +1,13 @@ +import Prelude as X + hiding ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) diff --git a/data/Test158.hs b/data/Test158.hs new file mode 100644 index 0000000..0fb60c8 --- /dev/null +++ b/data/Test158.hs @@ -0,0 +1,3 @@ +import TestJustAbitToLongModuleNameLikeThisOneIs + ( ) +import TestJustShortEnoughModuleNameLikeThisOne ( ) diff --git a/data/Test159.hs b/data/Test159.hs new file mode 100644 index 0000000..886dfdc --- /dev/null +++ b/data/Test159.hs @@ -0,0 +1,3 @@ +import TestJustAbitToLongModuleNameLikeThisOneI + as T +import TestJustShortEnoughModuleNameLikeThisOn as T diff --git a/data/Test16.hs b/data/Test16.hs new file mode 100644 index 0000000..a91f667 --- /dev/null +++ b/data/Test16.hs @@ -0,0 +1,6 @@ +func + :: asd + -> Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test160.hs b/data/Test160.hs new file mode 100644 index 0000000..eff7fd4 --- /dev/null +++ b/data/Test160.hs @@ -0,0 +1,3 @@ +import TestJustAbitToLongModuleNameLikeTh + hiding ( ) +import TestJustShortEnoughModuleNameLike hiding ( ) diff --git a/data/Test161.hs b/data/Test161.hs new file mode 100644 index 0000000..14bd638 --- /dev/null +++ b/data/Test161.hs @@ -0,0 +1,10 @@ +import MoreThanSufficientlyLongModuleNameWithSome + ( compact + , fit + , inA + , items + , layout + , not + , that + , will + ) diff --git a/data/Test162.hs b/data/Test162.hs new file mode 100644 index 0000000..f09b604 --- /dev/null +++ b/data/Test162.hs @@ -0,0 +1,11 @@ +import TestJustAbitToLongModuleNameLikeTh + hiding ( abc + , def + , ghci + , jklm + ) +import TestJustShortEnoughModuleNameLike hiding ( abc + , def + , ghci + , jklm + ) diff --git a/data/Test163.hs b/data/Test163.hs new file mode 100644 index 0000000..c71aaba --- /dev/null +++ b/data/Test163.hs @@ -0,0 +1,9 @@ +import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" A + hiding ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff + as T +import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe + ( ) diff --git a/data/Test164.hs b/data/Test164.hs new file mode 100644 index 0000000..26469d9 --- /dev/null +++ b/data/Test164.hs @@ -0,0 +1,7 @@ +-- Test +import Data.List ( nub ) -- Test +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} +-- Test +import Test ( test ) diff --git a/data/Test165.hs b/data/Test165.hs new file mode 100644 index 0000000..af0b6ab --- /dev/null +++ b/data/Test165.hs @@ -0,0 +1,4 @@ +import Test ( abc + , def + -- comment + ) diff --git a/data/Test166.hs b/data/Test166.hs new file mode 100644 index 0000000..3f0a3ea --- /dev/null +++ b/data/Test166.hs @@ -0,0 +1,3 @@ +import Test ( abc + -- comment + ) diff --git a/data/Test167.hs b/data/Test167.hs new file mode 100644 index 0000000..fb8c357 --- /dev/null +++ b/data/Test167.hs @@ -0,0 +1,8 @@ +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) diff --git a/data/Test168.hs b/data/Test168.hs new file mode 100644 index 0000000..40ca190 --- /dev/null +++ b/data/Test168.hs @@ -0,0 +1,2 @@ +import Test ( -- comment + ) diff --git a/data/Test169.hs b/data/Test169.hs new file mode 100644 index 0000000..12a8008 --- /dev/null +++ b/data/Test169.hs @@ -0,0 +1,8 @@ +import Test ( longbindingNameThatoverflowsColum + ) +import Test ( Long + ( List + , Of + , Things + ) + ) diff --git a/data/Test17.hs b/data/Test17.hs new file mode 100644 index 0000000..a4bf487 --- /dev/null +++ b/data/Test17.hs @@ -0,0 +1,6 @@ +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test170.hs b/data/Test170.hs new file mode 100644 index 0000000..01d0881 --- /dev/null +++ b/data/Test170.hs @@ -0,0 +1,18 @@ +import Test ( Thing + ( -- Comments + ) + ) +import Test ( Thing + ( Item + -- and Comment + ) + ) +import Test ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) + ) diff --git a/data/Test171.hs b/data/Test171.hs new file mode 100644 index 0000000..2716a8d --- /dev/null +++ b/data/Test171.hs @@ -0,0 +1,2 @@ +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + ( ) diff --git a/data/Test172.hs b/data/Test172.hs new file mode 100644 index 0000000..190cdb1 --- /dev/null +++ b/data/Test172.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE BangPatterns #-} +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + -- Test 10 + ) where +-- Test +import Data.List ( nub ) -- Test +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} +-- Test +import Test ( test ) diff --git a/data/Test173.hs b/data/Test173.hs new file mode 100644 index 0000000..ca49c29 --- /dev/null +++ b/data/Test173.hs @@ -0,0 +1,2 @@ +import Aaa +import Baa diff --git a/data/Test174.hs b/data/Test174.hs new file mode 100644 index 0000000..cb7a8f3 --- /dev/null +++ b/data/Test174.hs @@ -0,0 +1,5 @@ +import Zaa +import Zab + +import Aaa +import Baa diff --git a/data/Test175.hs b/data/Test175.hs new file mode 100644 index 0000000..b25e13a --- /dev/null +++ b/data/Test175.hs @@ -0,0 +1,2 @@ +import Boo +import qualified Zoo diff --git a/data/Test176.hs b/data/Test176.hs new file mode 100644 index 0000000..3ed3401 --- /dev/null +++ b/data/Test176.hs @@ -0,0 +1,3 @@ +import Boo ( a ) + +import Boo ( b ) diff --git a/data/Test177.hs b/data/Test177.hs new file mode 100644 index 0000000..67b690d --- /dev/null +++ b/data/Test177.hs @@ -0,0 +1,2 @@ +import A.B.C +import A.B.D diff --git a/data/Test178.hs b/data/Test178.hs new file mode 100644 index 0000000..f4d347f --- /dev/null +++ b/data/Test178.hs @@ -0,0 +1 @@ +type MySynonym = String diff --git a/data/Test179.hs b/data/Test179.hs new file mode 100644 index 0000000..dff281d --- /dev/null +++ b/data/Test179.hs @@ -0,0 +1 @@ +type MySynonym a = [a] diff --git a/data/Test18.hs b/data/Test18.hs new file mode 100644 index 0000000..aed66fd --- /dev/null +++ b/data/Test18.hs @@ -0,0 +1,5 @@ +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) diff --git a/data/Test180.hs b/data/Test180.hs new file mode 100644 index 0000000..3f41a1a --- /dev/null +++ b/data/Test180.hs @@ -0,0 +1,3 @@ +-- | Important comment thrown in +type MySynonym b a + = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b diff --git a/data/Test181.hs b/data/Test181.hs new file mode 100644 index 0000000..727c443 --- /dev/null +++ b/data/Test181.hs @@ -0,0 +1,7 @@ +type MySynonym3 b a + = MySynonym a b + -> MySynonym a b + -- ^ RandomComment + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a diff --git a/data/Test182.hs b/data/Test182.hs new file mode 100644 index 0000000..142a73a --- /dev/null +++ b/data/Test182.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE StarIsType #-} +type MySynonym (a :: * -> *) + = MySynonym a b + -> MySynonym a b + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a diff --git a/data/Test183.hs b/data/Test183.hs new file mode 100644 index 0000000..a48b11c --- /dev/null +++ b/data/Test183.hs @@ -0,0 +1 @@ +type MySynonym a = Num a => a -> Int diff --git a/data/Test184.hs b/data/Test184.hs new file mode 100644 index 0000000..7b868ea --- /dev/null +++ b/data/Test184.hs @@ -0,0 +1,5 @@ +type MySynonym a + = Num a + => AReallyLongTypeName + -> AnotherReallyLongTypeName + -> AThirdTypeNameToOverflow diff --git a/data/Test185.hs b/data/Test185.hs new file mode 100644 index 0000000..69107a7 --- /dev/null +++ b/data/Test185.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RankNTypes #-} +type MySynonym = forall a . [a] diff --git a/data/Test186.hs b/data/Test186.hs new file mode 100644 index 0000000..ed9c0e4 --- /dev/null +++ b/data/Test186.hs @@ -0,0 +1 @@ +type (:+:) a b = (a, b) diff --git a/data/Test187.hs b/data/Test187.hs new file mode 100644 index 0000000..3b94215 --- /dev/null +++ b/data/Test187.hs @@ -0,0 +1 @@ +type a `MySynonym` b = a -> b diff --git a/data/Test188.hs b/data/Test188.hs new file mode 100644 index 0000000..d7ba4a9 --- /dev/null +++ b/data/Test188.hs @@ -0,0 +1 @@ +type a :+: b = (a, b) diff --git a/data/Test189.hs b/data/Test189.hs new file mode 100644 index 0000000..7228f6d --- /dev/null +++ b/data/Test189.hs @@ -0,0 +1 @@ +type (a `Foo` b) c = (a, b, c) diff --git a/data/Test19.hs b/data/Test19.hs new file mode 100644 index 0000000..92634de --- /dev/null +++ b/data/Test19.hs @@ -0,0 +1,7 @@ +func + :: Trither + asd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test190.hs b/data/Test190.hs new file mode 100644 index 0000000..b686bf0 --- /dev/null +++ b/data/Test190.hs @@ -0,0 +1,3 @@ +type Foo a -- fancy type comment + = -- strange comment + Int diff --git a/data/Test191.hs b/data/Test191.hs new file mode 100644 index 0000000..b6ce836 --- /dev/null +++ b/data/Test191.hs @@ -0,0 +1 @@ +type (a :+: b) = (a, b) diff --git a/data/Test192.hs b/data/Test192.hs new file mode 100644 index 0000000..f08498a --- /dev/null +++ b/data/Test192.hs @@ -0,0 +1,6 @@ +type Foo + = ( -- t1 + A -- t2 + , -- t3 + B -- t4 + ) -- t5 diff --git a/data/Test193.hs b/data/Test193.hs new file mode 100644 index 0000000..b422133 --- /dev/null +++ b/data/Test193.hs @@ -0,0 +1,2 @@ +instance MyClass Int where + myMethod x = x + 1 diff --git a/data/Test194.hs b/data/Test194.hs new file mode 100644 index 0000000..69107c6 --- /dev/null +++ b/data/Test194.hs @@ -0,0 +1,4 @@ +instance MyClass Int where + myMethod x = + -- insightful comment + x + 1 diff --git a/data/Test195.hs b/data/Test195.hs new file mode 100644 index 0000000..3de314a --- /dev/null +++ b/data/Test195.hs @@ -0,0 +1,3 @@ +instance MyClass Int where + myMethod :: Int -> Int + myMethod x = x + 1 diff --git a/data/Test196.hs b/data/Test196.hs new file mode 100644 index 0000000..63f0d95 --- /dev/null +++ b/data/Test196.hs @@ -0,0 +1,9 @@ +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 diff --git a/data/Test197.hs b/data/Test197.hs new file mode 100644 index 0000000..d7c7d3c --- /dev/null +++ b/data/Test197.hs @@ -0,0 +1,3 @@ +instance MyClass Int where + myMethod x = x + 1 + myMethod2 x = x + 1 diff --git a/data/Test198.hs b/data/Test198.hs new file mode 100644 index 0000000..811e7c4 --- /dev/null +++ b/data/Test198.hs @@ -0,0 +1,11 @@ +instance MyClass Int where + myMethod + :: Int + -> Int + -> AReallyLongType + -> AReallyLongType + -> AReallyLongType + -> Int + myMethod x = x + 1 + myMethod2 :: Int -> Int + myMethod2 x = x + 1 diff --git a/data/Test199.hs b/data/Test199.hs new file mode 100644 index 0000000..9b9cf38 --- /dev/null +++ b/data/Test199.hs @@ -0,0 +1,4 @@ +-- | This instance should be commented on +instance MyClass Int where + -- | This method is also comment-worthy + myMethod x = x + 1 diff --git a/data/Test2.hs b/data/Test2.hs new file mode 100644 index 0000000..b0d734a --- /dev/null +++ b/data/Test2.hs @@ -0,0 +1,3 @@ +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test20.hs b/data/Test20.hs new file mode 100644 index 0000000..4ad54b6 --- /dev/null +++ b/data/Test20.hs @@ -0,0 +1,7 @@ +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test200.hs b/data/Test200.hs new file mode 100644 index 0000000..c184597 --- /dev/null +++ b/data/Test200.hs @@ -0,0 +1,4 @@ +instance MyClass Int where + type MyType = Int + myMethod :: MyType -> Int + myMethod x = x + 1 diff --git a/data/Test201.hs b/data/Test201.hs new file mode 100644 index 0000000..1dcbe3a --- /dev/null +++ b/data/Test201.hs @@ -0,0 +1,5 @@ +instance MyClass Int where + type MyType = String + myMethod :: MyType -> Int + myMethod x = x + 1 + type MyType = Int diff --git a/data/Test202.hs b/data/Test202.hs new file mode 100644 index 0000000..b2789c2 --- /dev/null +++ b/data/Test202.hs @@ -0,0 +1,8 @@ +instance MyClass Int where + -- | This data is very important + data MyData = IntData + { intData :: String + , intData2 :: Int + } + myMethod :: MyData -> Int + myMethod = intData2 diff --git a/data/Test203.hs b/data/Test203.hs new file mode 100644 index 0000000..04353a6 --- /dev/null +++ b/data/Test203.hs @@ -0,0 +1,11 @@ +instance MyClass Int where + -- | This data is important + data MyData = Test Int Int + myMethod :: MyData -> Int + myMethod = intData2 + -- | This data is also important + data MyData2 = IntData + { intData :: String + -- ^ Interesting field + , intData2 :: Int + } diff --git a/data/Test204.hs b/data/Test204.hs new file mode 100644 index 0000000..7ad4fc6 --- /dev/null +++ b/data/Test204.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module Lib where +instance Foo () where + newtype Bar () = Baz () + deriving (Eq, Ord, Show) + bar = Baz diff --git a/data/Test205.hs b/data/Test205.hs new file mode 100644 index 0000000..a224c18 --- /dev/null +++ b/data/Test205.hs @@ -0,0 +1,4 @@ +instance Foo Int where + newtype Bar Int = BarInt + { unBarInt :: Int + } diff --git a/data/Test206.hs b/data/Test206.hs new file mode 100644 index 0000000..7266b3e --- /dev/null +++ b/data/Test206.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +type family F a +type instance F Int = IO Int diff --git a/data/Test207.hs b/data/Test207.hs new file mode 100644 index 0000000..9bb7ba2 --- /dev/null +++ b/data/Test207.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +type family F a +type instance F Int = IO Int -- x diff --git a/data/Test208.hs b/data/Test208.hs new file mode 100644 index 0000000..0e3c3f8 --- /dev/null +++ b/data/Test208.hs @@ -0,0 +1,4 @@ +{-# language TypeFamilies #-} +module M where +type family F a +type instance F Int = IO Int diff --git a/data/Test209.hs b/data/Test209.hs new file mode 100644 index 0000000..f103480 --- /dev/null +++ b/data/Test209.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +newtype instance F Int = N Int diff --git a/data/Test21.hs b/data/Test21.hs new file mode 100644 index 0000000..d27183e --- /dev/null +++ b/data/Test21.hs @@ -0,0 +1,7 @@ +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test210.hs b/data/Test210.hs new file mode 100644 index 0000000..659bd8a --- /dev/null +++ b/data/Test210.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +newtype instance F Int = N Int -- x diff --git a/data/Test211.hs b/data/Test211.hs new file mode 100644 index 0000000..9e71377 --- /dev/null +++ b/data/Test211.hs @@ -0,0 +1,4 @@ +{-# language TypeFamilies #-} +module M where +data family F a +newtype instance F Int = N Int diff --git a/data/Test212.hs b/data/Test212.hs new file mode 100644 index 0000000..715990f --- /dev/null +++ b/data/Test212.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +data instance F Int = D Int diff --git a/data/Test213.hs b/data/Test213.hs new file mode 100644 index 0000000..0194c4c --- /dev/null +++ b/data/Test213.hs @@ -0,0 +1,3 @@ +{-# language TypeFamilies #-} +data family F a +data instance F Int = D Int -- x diff --git a/data/Test214.hs b/data/Test214.hs new file mode 100644 index 0000000..81d27db --- /dev/null +++ b/data/Test214.hs @@ -0,0 +1,4 @@ +{-# language TypeFamilies #-} +module M where +data family F a +data instance F Int = D Int diff --git a/data/Test215.hs b/data/Test215.hs new file mode 100644 index 0000000..feaf541 --- /dev/null +++ b/data/Test215.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + type family F a +instance C Int where + type F Int = IO Int diff --git a/data/Test216.hs b/data/Test216.hs new file mode 100644 index 0000000..13dcee5 --- /dev/null +++ b/data/Test216.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + type family F a +instance C Int where + type F Int = IO Int -- x diff --git a/data/Test217.hs b/data/Test217.hs new file mode 100644 index 0000000..c14956e --- /dev/null +++ b/data/Test217.hs @@ -0,0 +1,6 @@ +{-# language TypeFamilies #-} +module M where +class C a where + type family F a +instance C Int where + type F Int = IO Int diff --git a/data/Test218.hs b/data/Test218.hs new file mode 100644 index 0000000..824b034 --- /dev/null +++ b/data/Test218.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + newtype F Int = N Int diff --git a/data/Test219.hs b/data/Test219.hs new file mode 100644 index 0000000..1df22e4 --- /dev/null +++ b/data/Test219.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + newtype F Int = N Int -- x diff --git a/data/Test22.hs b/data/Test22.hs new file mode 100644 index 0000000..35b8134 --- /dev/null +++ b/data/Test22.hs @@ -0,0 +1,7 @@ +func + :: ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test220.hs b/data/Test220.hs new file mode 100644 index 0000000..6f6dc67 --- /dev/null +++ b/data/Test220.hs @@ -0,0 +1,6 @@ +{-# language TypeFamilies #-} +module M where +class C a where + data family F a +instance C Int where + newtype F Int = N Int diff --git a/data/Test221.hs b/data/Test221.hs new file mode 100644 index 0000000..1ec34f4 --- /dev/null +++ b/data/Test221.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + data F Int = D Int diff --git a/data/Test222.hs b/data/Test222.hs new file mode 100644 index 0000000..84a1f5f --- /dev/null +++ b/data/Test222.hs @@ -0,0 +1,5 @@ +{-# language TypeFamilies #-} +class C a where + data family F a +instance C Int where + data F Int = D Int -- x diff --git a/data/Test223.hs b/data/Test223.hs new file mode 100644 index 0000000..677369b --- /dev/null +++ b/data/Test223.hs @@ -0,0 +1,6 @@ +{-# language TypeFamilies #-} +module M where +class C a where + data family F a +instance C Int where + data F Int = D Int diff --git a/data/Test224.hs b/data/Test224.hs new file mode 100644 index 0000000..8798205 --- /dev/null +++ b/data/Test224.hs @@ -0,0 +1,3 @@ +module Main where +import Prelude +firstDecl = True diff --git a/data/Test225.hs b/data/Test225.hs new file mode 100644 index 0000000..e5861f4 --- /dev/null +++ b/data/Test225.hs @@ -0,0 +1,10 @@ +func = do + -- complex first step + aaa + -- complex second step + bbb + where + helper :: Helper + helper = helpful + other :: Other + other = True diff --git a/data/Test226.hs b/data/Test226.hs new file mode 100644 index 0000000..d999644 --- /dev/null +++ b/data/Test226.hs @@ -0,0 +1 @@ +type instance MyFam Bool = String diff --git a/data/Test227.hs b/data/Test227.hs new file mode 100644 index 0000000..a67980b --- /dev/null +++ b/data/Test227.hs @@ -0,0 +1 @@ +type instance MyFam (Maybe a) = a -> Bool diff --git a/data/Test228.hs b/data/Test228.hs new file mode 100644 index 0000000..21a82dc --- /dev/null +++ b/data/Test228.hs @@ -0,0 +1,4 @@ +type instance MyFam ALongishType + = AMuchLongerTypeThanThat + -> AnEvenLongerTypeThanTheLastOne + -> ShouldDefinitelyOverflow diff --git a/data/Test229.hs b/data/Test229.hs new file mode 100644 index 0000000..9299647 --- /dev/null +++ b/data/Test229.hs @@ -0,0 +1,3 @@ +-- | A happy family +type instance MyFam Bool -- This is an odd one + = AnotherType -- Here's another diff --git a/data/Test23.hs b/data/Test23.hs new file mode 100644 index 0000000..45b6ecc --- /dev/null +++ b/data/Test23.hs @@ -0,0 +1 @@ +func :: [a -> b] diff --git a/data/Test230.hs b/data/Test230.hs new file mode 100644 index 0000000..c7daa9c --- /dev/null +++ b/data/Test230.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} +func = if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test231.hs b/data/Test231.hs new file mode 100644 index 0000000..4580c39 --- /dev/null +++ b/data/Test231.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MultiWayIf #-} +func = do + foo + bar $ if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test232.hs b/data/Test232.hs new file mode 100644 index 0000000..a1e09b1 --- /dev/null +++ b/data/Test232.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LambdaCase #-} +func = \case + FooBar -> x + Baz -> y diff --git a/data/Test233.hs b/data/Test233.hs new file mode 100644 index 0000000..c4b3a93 --- /dev/null +++ b/data/Test233.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ImplicitParams #-} +func :: (?asd::Int) -> () diff --git a/data/Test234.hs b/data/Test234.hs new file mode 100644 index 0000000..55305cf --- /dev/null +++ b/data/Test234.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ImplicitParams #-} +func + :: ( ?asd + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> () diff --git a/data/Test235.hs b/data/Test235.hs new file mode 100644 index 0000000..41406a4 --- /dev/null +++ b/data/Test235.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RecursiveDo #-} +foo = do + rec a <- f b + b <- g a + return (a, b) diff --git a/data/Test236.hs b/data/Test236.hs new file mode 100644 index 0000000..ebf2076 --- /dev/null +++ b/data/Test236.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RecursiveDo #-} +foo = do + rec -- comment + a <- f b + b <- g a + return (a, b) diff --git a/data/Test237.hs b/data/Test237.hs new file mode 100644 index 0000000..78ecef2 --- /dev/null +++ b/data/Test237.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +module Test (type (++), (++), pattern Foo) where diff --git a/data/Test238.hs b/data/Test238.hs new file mode 100644 index 0000000..61444fa --- /dev/null +++ b/data/Test238.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +import Test ( type (++) + , (++) + , pattern (:.) + , pattern Foo + ) diff --git a/data/Test239.hs b/data/Test239.hs new file mode 100644 index 0000000..f535c48 --- /dev/null +++ b/data/Test239.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern J x = Just x diff --git a/data/Test24.hs b/data/Test24.hs new file mode 100644 index 0000000..272c2b4 --- /dev/null +++ b/data/Test24.hs @@ -0,0 +1,4 @@ +func + :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ] diff --git a/data/Test240.hs b/data/Test240.hs new file mode 100644 index 0000000..82251e5 --- /dev/null +++ b/data/Test240.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern F x <- (x, _) diff --git a/data/Test241.hs b/data/Test241.hs new file mode 100644 index 0000000..e00b3ca --- /dev/null +++ b/data/Test241.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern HeadC x <- x : xs where + HeadC x = [x] diff --git a/data/Test242.hs b/data/Test242.hs new file mode 100644 index 0000000..f6587d6 --- /dev/null +++ b/data/Test242.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern Head2 x y <- x : y : xs where + Head2 x y = [x, y] diff --git a/data/Test243.hs b/data/Test243.hs new file mode 100644 index 0000000..4ffaf11 --- /dev/null +++ b/data/Test243.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern x :> y = [x, y] diff --git a/data/Test244.hs b/data/Test244.hs new file mode 100644 index 0000000..d61801f --- /dev/null +++ b/data/Test244.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern MyData { a, b, c } = [a, b, c] diff --git a/data/Test245.hs b/data/Test245.hs new file mode 100644 index 0000000..78869f8 --- /dev/null +++ b/data/Test245.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = + [myLongLeftVariableName, myLongRightVariableName] diff --git a/data/Test246.hs b/data/Test246.hs new file mode 100644 index 0000000..811bb22 --- /dev/null +++ b/data/Test246.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- + [myLongLeftVariableName, myLongRightVariableName] where + MyInfixPatternMatcher x y = [x, x, y] diff --git a/data/Test247.hs b/data/Test247.hs new file mode 100644 index 0000000..cd38165 --- /dev/null +++ b/data/Test247.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern J :: a -> Maybe a +pattern J x = Just x diff --git a/data/Test248.hs b/data/Test248.hs new file mode 100644 index 0000000..823e1f4 --- /dev/null +++ b/data/Test248.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x diff --git a/data/Test249.hs b/data/Test249.hs new file mode 100644 index 0000000..9b69561 --- /dev/null +++ b/data/Test249.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- + (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x diff --git a/data/Test25.hs b/data/Test25.hs new file mode 100644 index 0000000..142958b --- /dev/null +++ b/data/Test25.hs @@ -0,0 +1,5 @@ +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test250.hs b/data/Test250.hs new file mode 100644 index 0000000..8493743 --- /dev/null +++ b/data/Test250.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x -- negative comment + Signed Zero = 0 -- zero comment + Signed (Pos x) = x -- positive comment diff --git a/data/Test251.hs b/data/Test251.hs new file mode 100644 index 0000000..3ea9b99 --- /dev/null +++ b/data/Test251.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern J, K :: a -> Maybe a diff --git a/data/Test252.hs b/data/Test252.hs new file mode 100644 index 0000000..54eb4c5 --- /dev/null +++ b/data/Test252.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +pattern LongMatcher + :: longlongtypevar + -> longlongtypevar + -> longlongtypevar + -> Maybe [longlongtypevar] +pattern LongMatcher x y z = Just [x, y, z] diff --git a/data/Test253.hs b/data/Test253.hs new file mode 100644 index 0000000..25fc4ce --- /dev/null +++ b/data/Test253.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnboxedTuples #-} +spanKey :: (# Int, Int #) -> (# Int, Int #) +spanKey = case foo of + (# bar, baz #) -> (# baz, bar #) diff --git a/data/Test254.hs b/data/Test254.hs new file mode 100644 index 0000000..3ceb254 --- /dev/null +++ b/data/Test254.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) +spanKey = case foo of + (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/data/Test255.hs b/data/Test255.hs new file mode 100644 index 0000000..a644156 --- /dev/null +++ b/data/Test255.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe + |] diff --git a/data/Test256.hs b/data/Test256.hs new file mode 100644 index 0000000..1624200 --- /dev/null +++ b/data/Test256.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} +func = [blub| + asd + qwe|] diff --git a/data/Test257.hs b/data/Test257.hs new file mode 100644 index 0000000..20f877f --- /dev/null +++ b/data/Test257.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +func = do + let body = [json| + hello + |] + pure True diff --git a/data/Test258.hs b/data/Test258.hs new file mode 100644 index 0000000..29039ca --- /dev/null +++ b/data/Test258.hs @@ -0,0 +1,9 @@ +-- brittany { lconfig_allowHangingQuasiQuotes: False } +{-# LANGUAGE QuasiQuotes #-} +func = do + let + body = + [json| + hello + |] + pure True diff --git a/data/Test259.hs b/data/Test259.hs new file mode 100644 index 0000000..2407ef8 --- /dev/null +++ b/data/Test259.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE OverloadedLabels #-} +foo = #bar diff --git a/data/Test26.hs b/data/Test26.hs new file mode 100644 index 0000000..cdc1e7e --- /dev/null +++ b/data/Test26.hs @@ -0,0 +1 @@ +func :: (a, b, c) diff --git a/data/Test260.hs b/data/Test260.hs new file mode 100644 index 0000000..d7cc187 --- /dev/null +++ b/data/Test260.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE OverloadedLabels #-} +foo = #bar . #baz $ fmap #foo xs diff --git a/data/Test261.hs b/data/Test261.hs new file mode 100644 index 0000000..f56379d --- /dev/null +++ b/data/Test261.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ImplicitParams #-} +foo = ?bar diff --git a/data/Test262.hs b/data/Test262.hs new file mode 100644 index 0000000..0ed092e --- /dev/null +++ b/data/Test262.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ImplicitParams #-} +foo = let ?bar = Foo in value diff --git a/data/Test263.hs b/data/Test263.hs new file mode 100644 index 0000000..a85a777 --- /dev/null +++ b/data/Test263.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE ImplicitParams #-} +foo :: (?bar::Bool) => () +foo = () diff --git a/data/Test264.hs b/data/Test264.hs new file mode 100644 index 0000000..d3ebee3 --- /dev/null +++ b/data/Test264.hs @@ -0,0 +1,4 @@ +func = do + abc <- foo +--abc +return () diff --git a/data/Test265.hs b/data/Test265.hs new file mode 100644 index 0000000..c965c63 --- /dev/null +++ b/data/Test265.hs @@ -0,0 +1 @@ +func = (()) diff --git a/data/Test266.hs b/data/Test266.hs new file mode 100644 index 0000000..b6a3539 --- /dev/null +++ b/data/Test266.hs @@ -0,0 +1,4 @@ +func = do + let foo True = True + foo _ = False + return () diff --git a/data/Test267.hs b/data/Test267.hs new file mode 100644 index 0000000..65d2172 --- /dev/null +++ b/data/Test267.hs @@ -0,0 +1,3 @@ +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } diff --git a/data/Test268.hs b/data/Test268.hs new file mode 100644 index 0000000..6d369d8 --- /dev/null +++ b/data/Test268.hs @@ -0,0 +1,5 @@ +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state + , _lstate_foo = _lstate_foo state + } diff --git a/data/Test269.hs b/data/Test269.hs new file mode 100644 index 0000000..4741485 --- /dev/null +++ b/data/Test269.hs @@ -0,0 +1,6 @@ +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test27.hs b/data/Test27.hs new file mode 100644 index 0000000..774cc9d --- /dev/null +++ b/data/Test27.hs @@ -0,0 +1 @@ +func :: ((a, b, c), (a, b, c), (a, b, c)) diff --git a/data/Test270.hs b/data/Test270.hs new file mode 100644 index 0000000..cd17597 --- /dev/null +++ b/data/Test270.hs @@ -0,0 +1 @@ +func = Foo { _lstate_indent = _lstate_indent state } diff --git a/data/Test271.hs b/data/Test271.hs new file mode 100644 index 0000000..112af5e --- /dev/null +++ b/data/Test271.hs @@ -0,0 +1,4 @@ +func = Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_fooo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test272.hs b/data/Test272.hs new file mode 100644 index 0000000..3d0a415 --- /dev/null +++ b/data/Test272.hs @@ -0,0 +1,4 @@ +func = do + Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test273.hs b/data/Test273.hs new file mode 100644 index 0000000..172b344 --- /dev/null +++ b/data/Test273.hs @@ -0,0 +1,4 @@ +func = do +-- abc + -- def + return () diff --git a/data/Test274.hs b/data/Test274.hs new file mode 100644 index 0000000..13d9924 --- /dev/null +++ b/data/Test274.hs @@ -0,0 +1,6 @@ +func = do + do + return () + -- abc + -- def + return () diff --git a/data/Test275.hs b/data/Test275.hs new file mode 100644 index 0000000..45fbb05 --- /dev/null +++ b/data/Test275.hs @@ -0,0 +1,6 @@ +func + :: Int -- basic indentation amount + -> Int -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + -> LayoutDesc + -> Int diff --git a/data/Test276.hs b/data/Test276.hs new file mode 100644 index 0000000..1a55b76 --- /dev/null +++ b/data/Test276.hs @@ -0,0 +1,7 @@ +func = + ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + $ abc + $ def + $ ghi + $ jkl + ) diff --git a/data/Test277.hs b/data/Test277.hs new file mode 100644 index 0000000..954c81d --- /dev/null +++ b/data/Test277.hs @@ -0,0 +1,2 @@ +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where reassoc (v, e, w) = (v, (e, w)) diff --git a/data/Test278.hs b/data/Test278.hs new file mode 100644 index 0000000..012222d --- /dev/null +++ b/data/Test278.hs @@ -0,0 +1,4 @@ +downloadRepoPackage = case repo of + RepoLocal {..} -> return () + RepoLocal { abc } -> return () + RepoLocal{} -> return () diff --git a/data/Test279.hs b/data/Test279.hs new file mode 100644 index 0000000..2a53d37 --- /dev/null +++ b/data/Test279.hs @@ -0,0 +1,6 @@ +func = do + let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' + (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' + -- default local dir target if there's no given target + utargets'' = "foo" + return () diff --git a/data/Test28.hs b/data/Test28.hs new file mode 100644 index 0000000..06bd705 --- /dev/null +++ b/data/Test28.hs @@ -0,0 +1,5 @@ +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test280.hs b/data/Test280.hs new file mode 100644 index 0000000..0ea93d9 --- /dev/null +++ b/data/Test280.hs @@ -0,0 +1,5 @@ +func = + [ (thing, take 10 alts) --TODO: select best ones + | (thing, _got, alts@(_ : _)) <- nosuchFooThing + , gast <- award + ] diff --git a/data/Test281.hs b/data/Test281.hs new file mode 100644 index 0000000..6366436 --- /dev/null +++ b/data/Test281.hs @@ -0,0 +1,5 @@ +func = if x + then if y -- y is important + then foo + else bar + else Nothing diff --git a/data/Test282.hs b/data/Test282.hs new file mode 100644 index 0000000..c6cba2d --- /dev/null +++ b/data/Test282.hs @@ -0,0 +1,7 @@ +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return $ Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR diff --git a/data/Test283.hs b/data/Test283.hs new file mode 100644 index 0000000..21044e6 --- /dev/null +++ b/data/Test283.hs @@ -0,0 +1,6 @@ +layoutWriteNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () diff --git a/data/Test284.hs b/data/Test284.hs new file mode 100644 index 0000000..f6a21c7 --- /dev/null +++ b/data/Test284.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MultiWayIf #-} +readMergePersConfig path shouldCreate conf = do + exists <- liftIO $ System.Directory.doesFileExist path + if + | exists -> do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn e + mzero + Right x -> return x + return $ fileConf Semigroup.<> conf + | shouldCreate -> do + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Option . Just . runIdentity) + staticDefaultConfig + return $ conf + | otherwise -> do + return conf diff --git a/data/Test285.hs b/data/Test285.hs new file mode 100644 index 0000000..388281d --- /dev/null +++ b/data/Test285.hs @@ -0,0 +1,12 @@ +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk diff --git a/data/Test286.hs b/data/Test286.hs new file mode 100644 index 0000000..388281d --- /dev/null +++ b/data/Test286.hs @@ -0,0 +1,12 @@ +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk diff --git a/data/Test287.hs b/data/Test287.hs new file mode 100644 index 0000000..a50af8b --- /dev/null +++ b/data/Test287.hs @@ -0,0 +1,35 @@ +showPackageDetailedInfo pkginfo = + renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) + $ char '*' + $+$ something + [ entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" + sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry + "Versions installed" + installedVersions + (altText + null + (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") + ) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) + then empty + else text "Modules:" + $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ] diff --git a/data/Test288.hs b/data/Test288.hs new file mode 100644 index 0000000..3289dd7 --- /dev/null +++ b/data/Test288.hs @@ -0,0 +1,2 @@ +isValidPosition position | validX && validY = Just position + | otherwise = Nothing diff --git a/data/Test289.hs b/data/Test289.hs new file mode 100644 index 0000000..023032c --- /dev/null +++ b/data/Test289.hs @@ -0,0 +1,6 @@ +foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do + (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String + -> IO Bool ) <- + ReflexHost.newExternalEvent + liftIO . forkIO . forever $ getLine >>= inputFire + ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent diff --git a/data/Test29.hs b/data/Test29.hs new file mode 100644 index 0000000..fc19ba1 --- /dev/null +++ b/data/Test29.hs @@ -0,0 +1,6 @@ +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test290.hs b/data/Test290.hs new file mode 100644 index 0000000..689fa70 --- /dev/null +++ b/data/Test290.hs @@ -0,0 +1,2 @@ +foldrDesc f z = unSwitchQueue $ \q -> + switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/data/Test291.hs b/data/Test291.hs new file mode 100644 index 0000000..68face0 --- /dev/null +++ b/data/Test291.hs @@ -0,0 +1,5 @@ +autocheckCases = + [ ("Never Deadlocks" , representative deadlocksNever) + , ("No Exceptions" , representative exceptionsNever) + , ("Consistent Result", alwaysSame) -- already representative + ] diff --git a/data/Test292.hs b/data/Test292.hs new file mode 100644 index 0000000..cc6ecb2 --- /dev/null +++ b/data/Test292.hs @@ -0,0 +1,7 @@ +autocheckCases = + [ ("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions" , representative exceptionsNever) + , ( "Consistent Result" + , alwaysSame -- already representative + ) + ] diff --git a/data/Test293.hs b/data/Test293.hs new file mode 100644 index 0000000..596f9ea --- /dev/null +++ b/data/Test293.hs @@ -0,0 +1,5 @@ +func = + [ (abc, (1111, 1111)) + , (def, (2, 2)) + , foo -- comment + ] diff --git a/data/Test294.hs b/data/Test294.hs new file mode 100644 index 0000000..927da51 --- /dev/null +++ b/data/Test294.hs @@ -0,0 +1,2 @@ +foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + where g a b = b + b * a diff --git a/data/Test295.hs b/data/Test295.hs new file mode 100644 index 0000000..2b6fc80 --- /dev/null +++ b/data/Test295.hs @@ -0,0 +1 @@ +foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo diff --git a/data/Test296.hs b/data/Test296.hs new file mode 100644 index 0000000..1954213 --- /dev/null +++ b/data/Test296.hs @@ -0,0 +1,5 @@ +func = do + abc <- expr + abcccccccccccccccccc <- expr + abcccccccccccccccccccccccccccccccccccccccccc <- expr + abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr diff --git a/data/Test297.hs b/data/Test297.hs new file mode 100644 index 0000000..198bd69 --- /dev/null +++ b/data/Test297.hs @@ -0,0 +1,3 @@ +func (MyLongFoo abc def) = 1 +func (Bar a d ) = 2 +func _ = 3 diff --git a/data/Test298.hs b/data/Test298.hs new file mode 100644 index 0000000..17013e2 --- /dev/null +++ b/data/Test298.hs @@ -0,0 +1,14 @@ +parserCompactLocation = + [ try + $ [ ParseRelAbs (Text.Read.read digits) _ _ + | digits <- many1 digit + , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe + [ case divPart of + Nothing -> Left $ Text.Read.read digits + Just ddigits -> + Right $ Text.Read.read digits % Text.Read.read ddigits + | digits <- many1 digit + , divPart <- optionMaybe (string "/" *> many1 digit) + ] + ] + ] diff --git a/data/Test299.hs b/data/Test299.hs new file mode 100644 index 0000000..26927f9 --- /dev/null +++ b/data/Test299.hs @@ -0,0 +1,3 @@ +func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test3.hs b/data/Test3.hs new file mode 100644 index 0000000..98d8196 --- /dev/null +++ b/data/Test3.hs @@ -0,0 +1,4 @@ +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj diff --git a/data/Test30.hs b/data/Test30.hs new file mode 100644 index 0000000..2ed144e --- /dev/null +++ b/data/Test30.hs @@ -0,0 +1,6 @@ +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test300.hs b/data/Test300.hs new file mode 100644 index 0000000..0338df4 --- /dev/null +++ b/data/Test300.hs @@ -0,0 +1,4 @@ +func = + fooooooooooooooooooooooooooooooooo + + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test301.hs b/data/Test301.hs new file mode 100644 index 0000000..bd8d21c --- /dev/null +++ b/data/Test301.hs @@ -0,0 +1,5 @@ +func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + [ foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + ] diff --git a/data/Test302.hs b/data/Test302.hs new file mode 100644 index 0000000..946346c --- /dev/null +++ b/data/Test302.hs @@ -0,0 +1,18 @@ +parserPrim = + [ r + | r <- + [ SGPPrimFloat $ bool id (0 -) minus $ readGnok "parserPrim" + (d1 ++ d2 ++ d3 ++ d4) + | d2 <- string "." + , d3 <- many1 (oneOf "0123456789") + , _ <- string "f" + ] + <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "f" + ] + <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "i" + ] + ] diff --git a/data/Test303.hs b/data/Test303.hs new file mode 100644 index 0000000..d3f4d9e --- /dev/null +++ b/data/Test303.hs @@ -0,0 +1,2 @@ +samples = (SV.unpackaaaaadat) <&> \f -> + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test304.hs b/data/Test304.hs new file mode 100644 index 0000000..c62bfc0 --- /dev/null +++ b/data/Test304.hs @@ -0,0 +1,9 @@ +runBrittany tabSize text = do + let config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text diff --git a/data/Test305.hs b/data/Test305.hs new file mode 100644 index 0000000..a288c39 --- /dev/null +++ b/data/Test305.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +runBrittany tabSize text = do + let + config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text diff --git a/data/Test306.hs b/data/Test306.hs new file mode 100644 index 0000000..822d18a --- /dev/null +++ b/data/Test306.hs @@ -0,0 +1,7 @@ +foo = + ( a + , -- comment1 + b + -- comment2 + , c + ) diff --git a/data/Test307.hs b/data/Test307.hs new file mode 100644 index 0000000..0d54fb5 --- /dev/null +++ b/data/Test307.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE TypeApplications #-} +foo = bar @Baz diff --git a/data/Test308.hs b/data/Test308.hs new file mode 100644 index 0000000..ca3fd97 --- /dev/null +++ b/data/Test308.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TypeApplications #-} +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do + docAlt + $ -- one-line solution + [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart + ] + ] + | not hasComments + , [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> [] + ] + ++ -- one-line solution + where in next line(s) + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , Data.Maybe.isJust mWhereDocs + ] + ++ -- two-line solution + where in next line(s) + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] diff --git a/data/Test309.hs b/data/Test309.hs new file mode 100644 index 0000000..d02a8c6 --- /dev/null +++ b/data/Test309.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiWayIf #-} +func = do + let foo = if + | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO + -> max + (defLen - 0.2) -- TODO + (defLen * 0.8) + | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO + return True diff --git a/data/Test31.hs b/data/Test31.hs new file mode 100644 index 0000000..7e217d5 --- /dev/null +++ b/data/Test31.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test310.hs b/data/Test310.hs new file mode 100644 index 0000000..a6f54fa --- /dev/null +++ b/data/Test310.hs @@ -0,0 +1,5 @@ +foo n = case n of + 1 -> True + -1 -> False +bar n = case n of + (-2, -2) -> (-2, -2) diff --git a/data/Test311.hs b/data/Test311.hs new file mode 100644 index 0000000..99e92c5 --- /dev/null +++ b/data/Test311.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} +foo = + let a = b @1 + cccc = () + in foo diff --git a/data/Test312.hs b/data/Test312.hs new file mode 100644 index 0000000..615e416 --- /dev/null +++ b/data/Test312.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RecordWildCards #-} +v = A { a = 1, .. } where b = 2 diff --git a/data/Test313.hs b/data/Test313.hs new file mode 100644 index 0000000..1f5f34f --- /dev/null +++ b/data/Test313.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RecordWildCards #-} +v = A { .. } where b = 2 diff --git a/data/Test314.hs b/data/Test314.hs new file mode 100644 index 0000000..e0cc55d --- /dev/null +++ b/data/Test314.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RecordWildCards #-} +v = A { a = 1, b = 2, c = 3 } diff --git a/data/Test315.hs b/data/Test315.hs new file mode 100644 index 0000000..8bd72ce --- /dev/null +++ b/data/Test315.hs @@ -0,0 +1 @@ +test :: Proxy 'Int diff --git a/data/Test316.hs b/data/Test316.hs new file mode 100644 index 0000000..e5a8eef --- /dev/null +++ b/data/Test316.hs @@ -0,0 +1 @@ +test :: Proxy '[ 'True] diff --git a/data/Test317.hs b/data/Test317.hs new file mode 100644 index 0000000..79d5442 --- /dev/null +++ b/data/Test317.hs @@ -0,0 +1 @@ +test :: Proxy '[Bool] diff --git a/data/Test318.hs b/data/Test318.hs new file mode 100644 index 0000000..f2c5673 --- /dev/null +++ b/data/Test318.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes, KindSignatures #-} +func + :: forall m str + . (Str str, Monad m) + => Int + -> Proxy (str :: [*]) + -> m (Tagged str String) diff --git a/data/Test319.hs b/data/Test319.hs new file mode 100644 index 0000000..1c6ce85 --- /dev/null +++ b/data/Test319.hs @@ -0,0 +1,13 @@ +widgetsDyn = + [ [ vBox + [ padTop Max outputLinesWidget + , padRight Max wid1 <+> flowWidget -- alignment here is strange/buggy + , padBottom (Pad 5) help + ] + ] + | wid1 <- promptDyn + , (flowWidget, _) <- flowResultD + , outputLinesWidget <- outputLinesWidgetD + , help <- suggestionHelpBox + , parser <- cmdParserD + ] diff --git a/data/Test32.hs b/data/Test32.hs new file mode 100644 index 0000000..19e72f4 --- /dev/null +++ b/data/Test32.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . Foo + => ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test320.hs b/data/Test320.hs new file mode 100644 index 0000000..c7e9eae --- /dev/null +++ b/data/Test320.hs @@ -0,0 +1,2 @@ +fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b +fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) diff --git a/data/Test321.hs b/data/Test321.hs new file mode 100644 index 0000000..5cee20d --- /dev/null +++ b/data/Test321.hs @@ -0,0 +1 @@ +cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] diff --git a/data/Test322.hs b/data/Test322.hs new file mode 100644 index 0000000..f515f6d --- /dev/null +++ b/data/Test322.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE TemplateHaskell #-} +deriveFromJSON (unPrefix "assignPost") ''AssignmentPost diff --git a/data/Test323.hs b/data/Test323.hs new file mode 100644 index 0000000..ae0ee2e --- /dev/null +++ b/data/Test323.hs @@ -0,0 +1,7 @@ +main = -- a + let --b + x = 1 -- x + y = 2 -- y + in do + print x + print y diff --git a/data/Test324.hs b/data/Test324.hs new file mode 100644 index 0000000..fcbe491 --- /dev/null +++ b/data/Test324.hs @@ -0,0 +1,9 @@ +alternatives :: Parser (Maybe Text) +alternatives = + alternativeOne -- first try this one + <|> alterantiveTwo -- then this one + <|> alternativeThree -- then this one + where + alternativeOne = purer "one" + alternativeTwo = purer "two" + alterantiveThree = purer "three" diff --git a/data/Test325.hs b/data/Test325.hs new file mode 100644 index 0000000..b8d67d0 --- /dev/null +++ b/data/Test325.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE BangPatterns #-} +func = do + let !forced = some + pure () diff --git a/data/Test326.hs b/data/Test326.hs new file mode 100644 index 0000000..0435d04 --- /dev/null +++ b/data/Test326.hs @@ -0,0 +1,4 @@ +spanKey p q = case minViewWithKey q of + Just ((k, _), q') | p k -> + let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') + _ -> ([], q) diff --git a/data/Test327.hs b/data/Test327.hs new file mode 100644 index 0000000..b7efa94 --- /dev/null +++ b/data/Test327.hs @@ -0,0 +1 @@ +a :: () ':- () diff --git a/data/Test328.hs b/data/Test328.hs new file mode 100644 index 0000000..c2ace2f --- /dev/null +++ b/data/Test328.hs @@ -0,0 +1,3 @@ +func = do + createDirectoryIfMissing True path + openFile fileName AppendMode diff --git a/data/Test329.hs b/data/Test329.hs new file mode 100644 index 0000000..449cf88 --- /dev/null +++ b/data/Test329.hs @@ -0,0 +1,7 @@ +alternatives :: Parser (Maybe Text) +alternatives = -- a + ( -- b + alternativeOne -- c + <|> alterantiveTwo -- d + <|> alternativeThree -- e + ) -- f diff --git a/data/Test33.hs b/data/Test33.hs new file mode 100644 index 0000000..335c68e --- /dev/null +++ b/data/Test33.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test330.hs b/data/Test330.hs new file mode 100644 index 0000000..0485ac6 --- /dev/null +++ b/data/Test330.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall a + . () + => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +func + :: () + => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test331.hs b/data/Test331.hs new file mode 100644 index 0000000..9737285 --- /dev/null +++ b/data/Test331.hs @@ -0,0 +1,5 @@ +go l [] = Right l +go l ((IRType, _a) : eqr) = go l eqr +go l ((_, IRType) : eqr) = go l eqr +go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 +go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 diff --git a/data/Test332.hs b/data/Test332.hs new file mode 100644 index 0000000..1785320 --- /dev/null +++ b/data/Test332.hs @@ -0,0 +1,2 @@ +type instance XPure StageParse = () +type Pair a = (a, a) diff --git a/data/Test333.hs b/data/Test333.hs new file mode 100644 index 0000000..0b87f50 --- /dev/null +++ b/data/Test333.hs @@ -0,0 +1,18 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = + let + eyuAfrarIso' + :: (RveoexdxunuAafalm -> Axlau (Axlau (a, OinejrdCplle))) + -> Gbodoy + -> Axlau (Axlau OinejrdCplle, Gbodoy) + eyuAfrarIso' = ulcPaaekBst cnehokzozwbVaguvu + amkgoxEhalazJjxunecCuIfaw + :: Axlau (Axlau OinejrdCplle, Gbodoy) -> Axlau RqlnrluYqednbCiggxi + amkgoxEhalazJjxunecCuIfaw uKqviuBisjtn = do + (sEmo, quc) <- uKqviuBisjtn + pure (xoheccewfWoeyiagOkfodiq sEmo quc) + xoheccewfWoeyiagOkfodiq + :: Axlau OinejrdCplle -> Gbodoy -> RqlnrluYqednbCiggxi + xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of + Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo + in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) diff --git a/data/Test334.hs b/data/Test334.hs new file mode 100644 index 0000000..f97dfd6 --- /dev/null +++ b/data/Test334.hs @@ -0,0 +1,5 @@ +spec = do + it "creates a snapshot at the given level" . withGraph runDB $ do + lift $ do + studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x + elaSnapshotReadingLevel snapshot `shouldBe` 12 diff --git a/data/Test335.hs b/data/Test335.hs new file mode 100644 index 0000000..0a2a760 --- /dev/null +++ b/data/Test335.hs @@ -0,0 +1,12 @@ +jaicyhHumzo btrKpeyiFej mava = do + m :: VtohxeRgpmgsu <- qloxIfiq mava + case m of + ZumnaoFujayerIswadabo kkecm chlixxag -> do + imomue <- ozisduRaqiseSBAob btrKpeyiFej $ \s -> + case MizA.pigevo kkecm (_tc_gulawulu s) of + Ebocaba -> + ( s { _tc_gulawulu = MizA.jxariu kkecm rwuRqxzhjo (_tc_gulawulu s) } + , Gtzvonm + ) + Xcde{} -> (s, Pioemav) + pure imomue diff --git a/data/Test336.hs b/data/Test336.hs new file mode 100644 index 0000000..5876f85 --- /dev/null +++ b/data/Test336.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyMultiple } +foo = bar + arg1 -- this is the first argument + arg2 -- this is the second argument + arg3 -- this is the third argument, now I'll skip one comment + arg4 + arg5 -- this is the fifth argument + arg6 -- this is the sixth argument diff --git a/data/Test337.hs b/data/Test337.hs new file mode 100644 index 0000000..917af95 --- /dev/null +++ b/data/Test337.hs @@ -0,0 +1,4 @@ +True `nand` True = False +nand _ _ = True +nor False False = True +_ `nor` _ = False diff --git a/data/Test338.hs b/data/Test338.hs new file mode 100644 index 0000000..e6df6c6 --- /dev/null +++ b/data/Test338.hs @@ -0,0 +1 @@ +f ((:) a as) = undefined diff --git a/data/Test339.hs b/data/Test339.hs new file mode 100644 index 0000000..cfa949d --- /dev/null +++ b/data/Test339.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +a = \x -> x +b = \ ~x -> x +c = \ !x -> x +d = \(~x) -> x diff --git a/data/Test34.hs b/data/Test34.hs new file mode 100644 index 0000000..24f6b28 --- /dev/null +++ b/data/Test34.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RankNTypes #-} +addFlagStringParam + :: forall f out + . (Applicative f) + => String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> String -- ^ param name + -> Flag String -- ^ properties + -> CmdParser f out String diff --git a/data/Test340.hs b/data/Test340.hs new file mode 100644 index 0000000..fb61bc1 --- /dev/null +++ b/data/Test340.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE RankNTypes #-} +func :: forall b . Show b => b -> String diff --git a/data/Test341.hs b/data/Test341.hs new file mode 100644 index 0000000..cea68da --- /dev/null +++ b/data/Test341.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TypeFamilies #-} +f :: ((~) a b) => a -> b +f = id diff --git a/data/Test342.hs b/data/Test342.hs new file mode 100644 index 0000000..c522948 --- /dev/null +++ b/data/Test342.hs @@ -0,0 +1,50 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +vakjkeSulxudbFokvir = Duotpo + { _ekku_gcrpbze = xgonae (1 :: Int) + , _oola_louwu = FoqsiYcuidx + { _xxagu_umea_iaztoj = xgonae False + , _tuktg_tizo_kfikacygsqf = xgonae False + , _ahzbo_xpow_otq_nzeyufq = xgonae False + , _uagpi_lzps_luy_xcjn = xgonae False + , _dxono_qjef_aqtafq_bes = xgonae False + , _yzuaf_nviy_vuhwxe_ihnbo_uhw = xgonae False + , _iwcit_fzjs_yerakt_dicox_mtryitko = xgonae False + , _ehjim_ucfe_dewarp_newrt_gso = xgonae False + , _ogtxb_ivoj_amqgai_rttui_xuwhetb = xgonae False + , _bhycb_iexz_megaug_qunoa_ohaked = xgonae False + , _nnmbe_uqgt_ewsuga_vaiis = xgonae False + , _otzil_ucvugaiyj_aosoiatunx_asir = xgonae False + } + , _iwsc_lalojz = XqspaiDainqw + { _uajznac_ugah = xgonae (80 :: Int) + , _qayziku_gazibzDejipj = xgonae DewizeCxwgyiKjig + , _auhebll_fiqjxyArfxia = xgonae (2 :: Int) + , _zubfuhq_dupiwnIoophXameeet = xgonae True + , _oavnuqg_opkreyOufuIkifiin = xgonae True + , _ufojfwy_fhuzcePeqwfu = xgonae (50 :: Int) + , _mlosikq_zajdxxSeRoelpf = xgonae (50 :: Int) + , _heemavf_fjgOfoaikh = xgonae (FyoVfvdygaZuzuvbeWarwuq 3) + , _ohxmeoq_ogtbfoPtqezVseu = xgonae (EdjotoLcbapUdiuMmytwoig 0.7) + , _omupuiu_ituamexjuLccwu = xgonae (30 :: Int) + , _xoseksf_atvwwdwaoHanofMyUvujjopoz = xgonae True + , _umuuuat_nuamezwWeqfUqzrnaxwp = xgonae False + , _uuriguz_wixhutbuKecigaFiwosret = xgonae True + , _betohxp_scixaLsvcesErtwItxrnaJmuz = xgonae False + , _lchxgee_olaetGcqzuqxVujenCzexub = xgonae True + , _egeibao_imamkuigqikhZdcbpidokVcixiqew = xgonae False + } + , _nloo_cfmrgZcisiugk = YuwodSavxwnicBekuel + { _oebew_rrtpvthUzlizjAqIwesly = xgonae False + , _blkff_Acxoid = xgonae False + , _datei_YewolAowoqOpunvpgu = xgonae BeekgUzojaPnixxaruJehyPmnnfu + , _ejfrj_eheb_justvh_pumcp_ismya = xgonae False + } + , _kena_uzeddovosoki = NyoRvshullezUpauud + { _mtfuwi_TUVEmoi = xgonae RZXKoytUtogx + , _larqam_adaxPehaylZafeqgpc = xgonae False + } + , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } + , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False + , _qaqb_eykzuyuwi = xgonae False + -- test comment + } diff --git a/data/Test343.hs b/data/Test343.hs new file mode 100644 index 0000000..bb5d7d2 --- /dev/null +++ b/data/Test343.hs @@ -0,0 +1,10 @@ +-- brittany { lconfig_indentPolicy: IndentPolicyLeft } +vakjkeSulxudbFokvir = Duotpo + { _ekku_gcrpbze = xgonae (1 :: Int) + , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } + , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False + , _qaqb_eykzuyuwi = xgonae False + -- test comment + , -- N.B. + .. -- x + } diff --git a/data/Test344.hs b/data/Test344.hs new file mode 100644 index 0000000..53649fc --- /dev/null +++ b/data/Test344.hs @@ -0,0 +1,7 @@ +func = abc + def + -- a + -- b + -- comment + where + abc = 13 + def = 1 diff --git a/data/Test345.hs b/data/Test345.hs new file mode 100644 index 0000000..613a398 --- /dev/null +++ b/data/Test345.hs @@ -0,0 +1,13 @@ +zItazySunefp twgq nlyo lwojjoBiecao = + let mhIarjyai = + ukwAausnfcn + $ XojlsTOSR.vuwOvuvdAZUOJaa + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.popjAyijoWarueeP + $ XojlsTOSR.jpwuPmafuDqlbkt nlyo + $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng + $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow + $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) + $ etOslnoz lwojjoBiecao + in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) diff --git a/data/Test346.hs b/data/Test346.hs new file mode 100644 index 0000000..83ba0bc --- /dev/null +++ b/data/Test346.hs @@ -0,0 +1,2 @@ +-- test +module MyModule where diff --git a/data/Test347.hs b/data/Test347.hs new file mode 100644 index 0000000..d01c656 --- /dev/null +++ b/data/Test347.hs @@ -0,0 +1,8 @@ +foo = + [ ("xxx", "xx") + , -- + ("xx" , "xx") + -- + , ("xx" , "xxxxx") + , ("xx" , "xx") + ] diff --git a/data/Test348.hs b/data/Test348.hs new file mode 100644 index 0000000..d0b4eb5 --- /dev/null +++ b/data/Test348.hs @@ -0,0 +1,8 @@ +foo = + [ ("xx", "xx") + , ( "xx" -- + , "xx" + ) + , ("xx", "xxxxx") + , ("xx", "xx") + ] diff --git a/data/Test349.hs b/data/Test349.hs new file mode 100644 index 0000000..0d374de --- /dev/null +++ b/data/Test349.hs @@ -0,0 +1,6 @@ +module Main + ( DataTypeI + , DataTypeII(DataConstructor) + -- * Haddock heading + , name + ) where diff --git a/data/Test35.hs b/data/Test35.hs new file mode 100644 index 0000000..7e217d5 --- /dev/null +++ b/data/Test35.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test350.hs b/data/Test350.hs new file mode 100644 index 0000000..0f5b4e9 --- /dev/null +++ b/data/Test350.hs @@ -0,0 +1,23 @@ +xeoeqibIaib + :: ( KqujhIsaus m + , XivuvIpoboi Droqifim m + , IgorvOtowtf m + , RyagaYaqac m + , QouruDU m + ) + => MaptAdfuxgu + -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd + -> QNOZqwuzg + -> Eoattuq + '[ XkatytdWdquraosu -- test comment + , KyezKijim -- another test comment + , DjmioeePuoeg + , NinrxoiOwezc + , QATAlrijacpk + , TrutvotwIwifiqOjdtu + , CoMmuatjwr + , BoZckzqyodseZole + , VagfwoXaeChfqe + ] + m + () diff --git a/data/Test351.hs b/data/Test351.hs new file mode 100644 index 0000000..fe25514 --- /dev/null +++ b/data/Test351.hs @@ -0,0 +1,7 @@ +createRedirectedProcess processConfig = do + let redirectedProc = (_processConfig_inner processConfig) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + foo diff --git a/data/Test352.hs b/data/Test352.hs new file mode 100644 index 0000000..3e5d558 --- /dev/null +++ b/data/Test352.hs @@ -0,0 +1,5 @@ +instance HasDependencies SomeDataModel where + -- N.B. Here is a bunch of explanatory context about the relationship + -- between these data models or whatever. + type Dependencies SomeDataModel + = (SomeOtherDataModelId, SomeOtherOtherDataModelId) diff --git a/data/Test353.hs b/data/Test353.hs new file mode 100644 index 0000000..cedb99d --- /dev/null +++ b/data/Test353.hs @@ -0,0 +1,4 @@ +func = + do + y + >>= x diff --git a/data/Test354.hs b/data/Test354.hs new file mode 100644 index 0000000..e082c6d --- /dev/null +++ b/data/Test354.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test355.hs b/data/Test355.hs new file mode 100644 index 0000000..56cf385 --- /dev/null +++ b/data/Test355.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo diff --git a/data/Test356.hs b/data/Test356.hs new file mode 100644 index 0000000..94a19a4 --- /dev/null +++ b/data/Test356.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_indentAmount: 8, lconfig_indentPolicy: IndentPolicyMultiple } +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo +foo = do + let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + foo diff --git a/data/Test357.hs b/data/Test357.hs new file mode 100644 index 0000000..9fd454a --- /dev/null +++ b/data/Test357.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } +foo = asdyf8asdf + "ajsdfas" + [ asjdf asyhf $ do + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ] diff --git a/data/Test358.hs b/data/Test358.hs new file mode 100644 index 0000000..7a121e7 --- /dev/null +++ b/data/Test358.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: a -> a diff --git a/data/Test359.hs b/data/Test359.hs new file mode 100644 index 0000000..6991c53 --- /dev/null +++ b/data/Test359.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test36.hs b/data/Test36.hs new file mode 100644 index 0000000..7fc70e4 --- /dev/null +++ b/data/Test36.hs @@ -0,0 +1 @@ +func :: a -> b -- comment diff --git a/data/Test360.hs b/data/Test360.hs new file mode 100644 index 0000000..b7c0128 --- /dev/null +++ b/data/Test360.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj diff --git a/data/Test361.hs b/data/Test361.hs new file mode 100644 index 0000000..ffd3ff9 --- /dev/null +++ b/data/Test361.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: ((a)) diff --git a/data/Test362.hs b/data/Test362.hs new file mode 100644 index 0000000..df79511 --- /dev/null +++ b/data/Test362.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: (a -> a) -> a diff --git a/data/Test363.hs b/data/Test363.hs new file mode 100644 index 0000000..921d92d --- /dev/null +++ b/data/Test363.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: a -> (a -> a) diff --git a/data/Test364.hs b/data/Test364.hs new file mode 100644 index 0000000..ed845fb --- /dev/null +++ b/data/Test364.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: (((((((((()))))))))) +-- current output is.. funny. wonder if that can/needs to be improved.. diff --git a/data/Test365.hs b/data/Test365.hs new file mode 100644 index 0000000..bf8f673 --- /dev/null +++ b/data/Test365.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: () diff --git a/data/Test366.hs b/data/Test366.hs new file mode 100644 index 0000000..a478841 --- /dev/null +++ b/data/Test366.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + ) diff --git a/data/Test367.hs b/data/Test367.hs new file mode 100644 index 0000000..165c111 --- /dev/null +++ b/data/Test367.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) diff --git a/data/Test368.hs b/data/Test368.hs new file mode 100644 index 0000000..4a1e980 --- /dev/null +++ b/data/Test368.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) + -> lakjsdlkjasldkj diff --git a/data/Test369.hs b/data/Test369.hs new file mode 100644 index 0000000..ed4d90c --- /dev/null +++ b/data/Test369.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> lakjsdlkjasldkj diff --git a/data/Test37.hs b/data/Test37.hs new file mode 100644 index 0000000..70aa3c6 --- /dev/null +++ b/data/Test37.hs @@ -0,0 +1,2 @@ +funcA :: a -> b -- comment A +funcB :: a -> b -- comment B diff --git a/data/Test370.hs b/data/Test370.hs new file mode 100644 index 0000000..4621ea3 --- /dev/null +++ b/data/Test370.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test371.hs b/data/Test371.hs new file mode 100644 index 0000000..0ec2ac4 --- /dev/null +++ b/data/Test371.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: asd -> Either a b diff --git a/data/Test372.hs b/data/Test372.hs new file mode 100644 index 0000000..2adc98c --- /dev/null +++ b/data/Test372.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> Either + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test373.hs b/data/Test373.hs new file mode 100644 index 0000000..faee723 --- /dev/null +++ b/data/Test373.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test374.hs b/data/Test374.hs new file mode 100644 index 0000000..be2766e --- /dev/null +++ b/data/Test374.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test375.hs b/data/Test375.hs new file mode 100644 index 0000000..6efe43f --- /dev/null +++ b/data/Test375.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) diff --git a/data/Test376.hs b/data/Test376.hs new file mode 100644 index 0000000..8d7a7ae --- /dev/null +++ b/data/Test376.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: Trither + asd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test377.hs b/data/Test377.hs new file mode 100644 index 0000000..16d6ee7 --- /dev/null +++ b/data/Test377.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test378.hs b/data/Test378.hs new file mode 100644 index 0000000..b7a24ca --- /dev/null +++ b/data/Test378.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test379.hs b/data/Test379.hs new file mode 100644 index 0000000..50f95b2 --- /dev/null +++ b/data/Test379.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd diff --git a/data/Test38.hs b/data/Test38.hs new file mode 100644 index 0000000..6978eb6 --- /dev/null +++ b/data/Test38.hs @@ -0,0 +1,11 @@ +-- a +func -- b + :: -- c + a -- d + -> -- e + ( -- f + c -- g + , -- h + d -- i + ) -- j +-- k diff --git a/data/Test380.hs b/data/Test380.hs new file mode 100644 index 0000000..4453786 --- /dev/null +++ b/data/Test380.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: [a -> b] diff --git a/data/Test381.hs b/data/Test381.hs new file mode 100644 index 0000000..faf63f1 --- /dev/null +++ b/data/Test381.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ] diff --git a/data/Test382.hs b/data/Test382.hs new file mode 100644 index 0000000..fbcaa1c --- /dev/null +++ b/data/Test382.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test383.hs b/data/Test383.hs new file mode 100644 index 0000000..edfefd8 --- /dev/null +++ b/data/Test383.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: (a, b, c) diff --git a/data/Test384.hs b/data/Test384.hs new file mode 100644 index 0000000..cb8e4cd --- /dev/null +++ b/data/Test384.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: ((a, b, c), (a, b, c), (a, b, c)) diff --git a/data/Test385.hs b/data/Test385.hs new file mode 100644 index 0000000..8177c7f --- /dev/null +++ b/data/Test385.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) diff --git a/data/Test386.hs b/data/Test386.hs new file mode 100644 index 0000000..e3efa79 --- /dev/null +++ b/data/Test386.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) diff --git a/data/Test387.hs b/data/Test387.hs new file mode 100644 index 0000000..3a64ee9 --- /dev/null +++ b/data/Test387.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] diff --git a/data/Test388.hs b/data/Test388.hs new file mode 100644 index 0000000..15b0b06 --- /dev/null +++ b/data/Test388.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test389.hs b/data/Test389.hs new file mode 100644 index 0000000..5acb0b6 --- /dev/null +++ b/data/Test389.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . Foo + => ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test39.hs b/data/Test39.hs new file mode 100644 index 0000000..9c9b324 --- /dev/null +++ b/data/Test39.hs @@ -0,0 +1,4 @@ +func = f + where + {-# INLINE f #-} + f = id diff --git a/data/Test390.hs b/data/Test390.hs new file mode 100644 index 0000000..72f2d0a --- /dev/null +++ b/data/Test390.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () diff --git a/data/Test391.hs b/data/Test391.hs new file mode 100644 index 0000000..15b0b06 --- /dev/null +++ b/data/Test391.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b diff --git a/data/Test392.hs b/data/Test392.hs new file mode 100644 index 0000000..de8ad75 --- /dev/null +++ b/data/Test392.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func :: a -> b -- comment diff --git a/data/Test393.hs b/data/Test393.hs new file mode 100644 index 0000000..1a15a53 --- /dev/null +++ b/data/Test393.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +funcA :: a -> b -- comment A +funcB :: a -> b -- comment B diff --git a/data/Test394.hs b/data/Test394.hs new file mode 100644 index 0000000..44eb854 --- /dev/null +++ b/data/Test394.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- a +func -- b + :: -- c + a -- d + -> -- e + ( -- f + c -- g + , -- h + d -- i + ) -- j-- k diff --git a/data/Test395.hs b/data/Test395.hs new file mode 100644 index 0000000..729290d --- /dev/null +++ b/data/Test395.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ImplicitParams #-} +func :: (?asd::Int) -> () diff --git a/data/Test396.hs b/data/Test396.hs new file mode 100644 index 0000000..f706d17 --- /dev/null +++ b/data/Test396.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE ImplicitParams #-} +func + :: ( ?asd + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> () diff --git a/data/Test397.hs b/data/Test397.hs new file mode 100644 index 0000000..750f3f9 --- /dev/null +++ b/data/Test397.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = f + where + {-# INLINE f #-} + f = id diff --git a/data/Test398.hs b/data/Test398.hs new file mode 100644 index 0000000..8770767 --- /dev/null +++ b/data/Test398.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = ($) + where + {-# INLINE ($) #-} + ($) = id diff --git a/data/Test399.hs b/data/Test399.hs new file mode 100644 index 0000000..996e831 --- /dev/null +++ b/data/Test399.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = f + where + {-# INLINE CONLIKE [1] f #-} + f = id diff --git a/data/Test4.hs b/data/Test4.hs new file mode 100644 index 0000000..e517aa0 --- /dev/null +++ b/data/Test4.hs @@ -0,0 +1 @@ +func :: ((a)) diff --git a/data/Test40.hs b/data/Test40.hs new file mode 100644 index 0000000..c182430 --- /dev/null +++ b/data/Test40.hs @@ -0,0 +1,4 @@ +func = ($) + where + {-# INLINE ($) #-} + ($) = id diff --git a/data/Test400.hs b/data/Test400.hs new file mode 100644 index 0000000..8b00a95 --- /dev/null +++ b/data/Test400.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = f + where + {-# INLINE [~1] f #-} + f = id diff --git a/data/Test401.hs b/data/Test401.hs new file mode 100644 index 0000000..7d334ba --- /dev/null +++ b/data/Test401.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + } diff --git a/data/Test402.hs b/data/Test402.hs new file mode 100644 index 0000000..f94f463 --- /dev/null +++ b/data/Test402.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo, bar :: Baz + } diff --git a/data/Test403.hs b/data/Test403.hs new file mode 100644 index 0000000..3b2e688 --- /dev/null +++ b/data/Test403.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } diff --git a/data/Test404.hs b/data/Test404.hs new file mode 100644 index 0000000..9144cc0 --- /dev/null +++ b/data/Test404.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } diff --git a/data/Test405.hs b/data/Test405.hs new file mode 100644 index 0000000..7d20e0d --- /dev/null +++ b/data/Test405.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving Show diff --git a/data/Test406.hs b/data/Test406.hs new file mode 100644 index 0000000..cfe7ae2 --- /dev/null +++ b/data/Test406.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test407.hs b/data/Test407.hs new file mode 100644 index 0000000..b889d43 --- /dev/null +++ b/data/Test407.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x = x diff --git a/data/Test408.hs b/data/Test408.hs new file mode 100644 index 0000000..2764fb5 --- /dev/null +++ b/data/Test408.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +x *** y = x diff --git a/data/Test409.hs b/data/Test409.hs new file mode 100644 index 0000000..a9a0917 --- /dev/null +++ b/data/Test409.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +(***) x y = x diff --git a/data/Test41.hs b/data/Test41.hs new file mode 100644 index 0000000..205a728 --- /dev/null +++ b/data/Test41.hs @@ -0,0 +1,4 @@ +func = f + where + {-# INLINE CONLIKE [1] f #-} + f = id diff --git a/data/Test410.hs b/data/Test410.hs new file mode 100644 index 0000000..155d06d --- /dev/null +++ b/data/Test410.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func _ = x diff --git a/data/Test411.hs b/data/Test411.hs new file mode 100644 index 0000000..73dc40a --- /dev/null +++ b/data/Test411.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = + x diff --git a/data/Test412.hs b/data/Test412.hs new file mode 100644 index 0000000..92a61f3 --- /dev/null +++ b/data/Test412.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x diff --git a/data/Test413.hs b/data/Test413.hs new file mode 100644 index 0000000..a5f08d9 --- /dev/null +++ b/data/Test413.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b + = x diff --git a/data/Test414.hs b/data/Test414.hs new file mode 100644 index 0000000..c0690eb --- /dev/null +++ b/data/Test414.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (A a) = a diff --git a/data/Test415.hs b/data/Test415.hs new file mode 100644 index 0000000..fb95ff8 --- /dev/null +++ b/data/Test415.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (x : xr) = x diff --git a/data/Test416.hs b/data/Test416.hs new file mode 100644 index 0000000..490720c --- /dev/null +++ b/data/Test416.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (x :+: xr) = x diff --git a/data/Test417.hs b/data/Test417.hs new file mode 100644 index 0000000..8ee6b8b --- /dev/null +++ b/data/Test417.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func | True = x diff --git a/data/Test418.hs b/data/Test418.hs new file mode 100644 index 0000000..506b4d1 --- /dev/null +++ b/data/Test418.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | x = simple expression + | otherwise = 0 diff --git a/data/Test419.hs b/data/Test419.hs new file mode 100644 index 0000000..ee128f1 --- /dev/null +++ b/data/Test419.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | a somewhat longer guard x = "and a somewhat longer expession that does not" + | otherwise = "fit without putting the guards in new lines" diff --git a/data/Test42.hs b/data/Test42.hs new file mode 100644 index 0000000..cfd38bb --- /dev/null +++ b/data/Test42.hs @@ -0,0 +1,2 @@ +{-# NOINLINE func #-} +func :: Int diff --git a/data/Test420.hs b/data/Test420.hs new file mode 100644 index 0000000..a8f1881 --- /dev/null +++ b/data/Test420.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | very long guard, another rather long guard that refers to x = nontrivial + expression + foo + bar + alsdkjlasdjlasj + | otherwise = 0 diff --git a/data/Test421.hs b/data/Test421.hs new file mode 100644 index 0000000..5dd669d --- /dev/null +++ b/data/Test421.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | very long guard, another rather long guard that refers to x + = nontrivialexpression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test422.hs b/data/Test422.hs new file mode 100644 index 0000000..830e3ee --- /dev/null +++ b/data/Test422.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func x + | very loooooooooooooooooooooooooooooong guard + , another rather long guard that refers to x + = nontrivial expression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test423.hs b/data/Test423.hs new file mode 100644 index 0000000..88d75b3 --- /dev/null +++ b/data/Test423.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = x +describe "infix op" $ do diff --git a/data/Test424.hs b/data/Test424.hs new file mode 100644 index 0000000..1258fc6 --- /dev/null +++ b/data/Test424.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = x + x diff --git a/data/Test425.hs b/data/Test425.hs new file mode 100644 index 0000000..1ed0c86 --- /dev/null +++ b/data/Test425.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test426.hs b/data/Test426.hs new file mode 100644 index 0000000..e70a294 --- /dev/null +++ b/data/Test426.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj diff --git a/data/Test427.hs b/data/Test427.hs new file mode 100644 index 0000000..38b5fd2 --- /dev/null +++ b/data/Test427.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test428.hs b/data/Test428.hs new file mode 100644 index 0000000..ab8bc90 --- /dev/null +++ b/data/Test428.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = 1 +func = "abc" +func = 1.1e5 +func = 'x' +func = 981409823458910394810928414192837123987123987123 diff --git a/data/Test429.hs b/data/Test429.hs new file mode 100644 index 0000000..6fcf5ea --- /dev/null +++ b/data/Test429.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE LambdaCase #-} +func = \case + FooBar -> x + Baz -> y diff --git a/data/Test43.hs b/data/Test43.hs new file mode 100644 index 0000000..83572d8 --- /dev/null +++ b/data/Test43.hs @@ -0,0 +1,4 @@ +func = f + where + {-# INLINE [~1] f #-} + f = id diff --git a/data/Test430.hs b/data/Test430.hs new file mode 100644 index 0000000..3efc267 --- /dev/null +++ b/data/Test430.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = \x -> abc +describe "app" $ do diff --git a/data/Test431.hs b/data/Test431.hs new file mode 100644 index 0000000..c1c1c58 --- /dev/null +++ b/data/Test431.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = klajsdas klajsdas klajsdas diff --git a/data/Test432.hs b/data/Test432.hs new file mode 100644 index 0000000..aa2b380 --- /dev/null +++ b/data/Test432.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd diff --git a/data/Test433.hs b/data/Test433.hs new file mode 100644 index 0000000..851e5cb --- /dev/null +++ b/data/Test433.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljas + lakjsdlajsdljas + lakjsdlajsdljas diff --git a/data/Test434.hs b/data/Test434.hs new file mode 100644 index 0000000..f52edc1 --- /dev/null +++ b/data/Test434.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (1 +) diff --git a/data/Test435.hs b/data/Test435.hs new file mode 100644 index 0000000..09d341e --- /dev/null +++ b/data/Test435.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (+ 1) diff --git a/data/Test436.hs b/data/Test436.hs new file mode 100644 index 0000000..25a7bda --- /dev/null +++ b/data/Test436.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (1 `abc`) diff --git a/data/Test437.hs b/data/Test437.hs new file mode 100644 index 0000000..3c56cf8 --- /dev/null +++ b/data/Test437.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (`abc` 1) diff --git a/data/Test438.hs b/data/Test438.hs new file mode 100644 index 0000000..a9c30d5 --- /dev/null +++ b/data/Test438.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (abc, def) diff --git a/data/Test439.hs b/data/Test439.hs new file mode 100644 index 0000000..90cb29d --- /dev/null +++ b/data/Test439.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + ) diff --git a/data/Test44.hs b/data/Test44.hs new file mode 100644 index 0000000..7dd43f0 --- /dev/null +++ b/data/Test44.hs @@ -0,0 +1,2 @@ +data Foo = Bar {} +data Biz = Baz diff --git a/data/Test440.hs b/data/Test440.hs new file mode 100644 index 0000000..0d46933 --- /dev/null +++ b/data/Test440.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo = + let longIdentifierForShortValue = 1 + in longIdentifierForShortValue + longIdentifierForShortValue diff --git a/data/Test441.hs b/data/Test441.hs new file mode 100644 index 0000000..6a77a85 --- /dev/null +++ b/data/Test441.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + stmt + stmt diff --git a/data/Test442.hs b/data/Test442.hs new file mode 100644 index 0000000..3ab95e7 --- /dev/null +++ b/data/Test442.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + x <- stmt + stmt x diff --git a/data/Test443.hs b/data/Test443.hs new file mode 100644 index 0000000..c832f21 --- /dev/null +++ b/data/Test443.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let x = 13 + stmt x diff --git a/data/Test444.hs b/data/Test444.hs new file mode 100644 index 0000000..31b1cc7 --- /dev/null +++ b/data/Test444.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + foooooo + $ [ case + foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + of + _ -> True + ] diff --git a/data/Test445.hs b/data/Test445.hs new file mode 100644 index 0000000..c3f325f --- /dev/null +++ b/data/Test445.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +func = if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test446.hs b/data/Test446.hs new file mode 100644 index 0000000..4d8efd2 --- /dev/null +++ b/data/Test446.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +func = do + foo + bar $ if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test447.hs b/data/Test447.hs new file mode 100644 index 0000000..6e718f0 --- /dev/null +++ b/data/Test447.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + foo + $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + ] + ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] diff --git a/data/Test448.hs b/data/Test448.hs new file mode 100644 index 0000000..3884989 --- /dev/null +++ b/data/Test448.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main where diff --git a/data/Test449.hs b/data/Test449.hs new file mode 100644 index 0000000..7a6295f --- /dev/null +++ b/data/Test449.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main () where diff --git a/data/Test45.hs b/data/Test45.hs new file mode 100644 index 0000000..d1c8c85 --- /dev/null +++ b/data/Test45.hs @@ -0,0 +1,3 @@ +data Foo = Bar + { foo :: Baz + } diff --git a/data/Test450.hs b/data/Test450.hs new file mode 100644 index 0000000..89316b0 --- /dev/null +++ b/data/Test450.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (main) where diff --git a/data/Test451.hs b/data/Test451.hs new file mode 100644 index 0000000..a55d851 --- /dev/null +++ b/data/Test451.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (main, test1, test2) where diff --git a/data/Test452.hs b/data/Test452.hs new file mode 100644 index 0000000..4fe8cbf --- /dev/null +++ b/data/Test452.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) where diff --git a/data/Test453.hs b/data/Test453.hs new file mode 100644 index 0000000..eaeb665 --- /dev/null +++ b/data/Test453.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main + ( main + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) where diff --git a/data/Test454.hs b/data/Test454.hs new file mode 100644 index 0000000..c2e7a8e --- /dev/null +++ b/data/Test454.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (Test(..)) where diff --git a/data/Test455.hs b/data/Test455.hs new file mode 100644 index 0000000..6191afd --- /dev/null +++ b/data/Test455.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (module Main) where diff --git a/data/Test456.hs b/data/Test456.hs new file mode 100644 index 0000000..3d9694b --- /dev/null +++ b/data/Test456.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (Test(Test, a, b)) where diff --git a/data/Test457.hs b/data/Test457.hs new file mode 100644 index 0000000..82a8e14 --- /dev/null +++ b/data/Test457.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +module Main (Test()) where diff --git a/data/Test458.hs b/data/Test458.hs new file mode 100644 index 0000000..df50e76 --- /dev/null +++ b/data/Test458.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- Intentionally left empty diff --git a/data/Test459.hs b/data/Test459.hs new file mode 100644 index 0000000..0dea4be --- /dev/null +++ b/data/Test459.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List diff --git a/data/Test46.hs b/data/Test46.hs new file mode 100644 index 0000000..2472782 --- /dev/null +++ b/data/Test46.hs @@ -0,0 +1,3 @@ +data Foo = Bar + { foo, bar :: Baz + } diff --git a/data/Test460.hs b/data/Test460.hs new file mode 100644 index 0000000..50b8621 --- /dev/null +++ b/data/Test460.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List as L diff --git a/data/Test461.hs b/data/Test461.hs new file mode 100644 index 0000000..835646b --- /dev/null +++ b/data/Test461.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified Data.List diff --git a/data/Test462.hs b/data/Test462.hs new file mode 100644 index 0000000..7e772a5 --- /dev/null +++ b/data/Test462.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified Data.List as L diff --git a/data/Test463.hs b/data/Test463.hs new file mode 100644 index 0000000..1bfa264 --- /dev/null +++ b/data/Test463.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import safe Data.List as L diff --git a/data/Test464.hs b/data/Test464.hs new file mode 100644 index 0000000..53fad4c --- /dev/null +++ b/data/Test464.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import {-# SOURCE #-} Data.List () diff --git a/data/Test465.hs b/data/Test465.hs new file mode 100644 index 0000000..8e5b381 --- /dev/null +++ b/data/Test465.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import safe qualified Data.List hiding (nub) diff --git a/data/Test466.hs b/data/Test466.hs new file mode 100644 index 0000000..73046d6 --- /dev/null +++ b/data/Test466.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import {-# SOURCE #-} safe qualified Data.List diff --git a/data/Test467.hs b/data/Test467.hs new file mode 100644 index 0000000..7745833 --- /dev/null +++ b/data/Test467.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified "base" Data.List diff --git a/data/Test468.hs b/data/Test468.hs new file mode 100644 index 0000000..2c704b4 --- /dev/null +++ b/data/Test468.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List () +import {-# SOURCE #-} safe qualified Data.List hiding () diff --git a/data/Test469.hs b/data/Test469.hs new file mode 100644 index 0000000..fa53576 --- /dev/null +++ b/data/Test469.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import qualified Data.List () diff --git a/data/Test47.hs b/data/Test47.hs new file mode 100644 index 0000000..2dbac94 --- /dev/null +++ b/data/Test47.hs @@ -0,0 +1,4 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } diff --git a/data/Test470.hs b/data/Test470.hs new file mode 100644 index 0000000..97ce770 --- /dev/null +++ b/data/Test470.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List (nub) diff --git a/data/Test471.hs b/data/Test471.hs new file mode 100644 index 0000000..fb499b1 --- /dev/null +++ b/data/Test471.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Data.List (foldl', indexElem, nub) diff --git a/data/Test472.hs b/data/Test472.hs new file mode 100644 index 0000000..39cfd67 --- /dev/null +++ b/data/Test472.hs @@ -0,0 +1,16 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( Long + , anymore + , fit + , items + , line + , list + , not + , onA + , quite + , single + , that + , will + , with + ) diff --git a/data/Test473.hs b/data/Test473.hs new file mode 100644 index 0000000..016a6b7 --- /dev/null +++ b/data/Test473.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>))) diff --git a/data/Test474.hs b/data/Test474.hs new file mode 100644 index 0000000..1716691 --- /dev/null +++ b/data/Test474.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test hiding () +import Test as T hiding () diff --git a/data/Test475.hs b/data/Test475.hs new file mode 100644 index 0000000..adbfb6e --- /dev/null +++ b/data/Test475.hs @@ -0,0 +1,15 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Prelude as X + hiding + ( head + , init + , last + , maximum + , minimum + , pred + , read + , readFile + , succ + , tail + , undefined + ) diff --git a/data/Test476.hs b/data/Test476.hs new file mode 100644 index 0000000..900fb1f --- /dev/null +++ b/data/Test476.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import MoreThanSufficientlyLongModuleNameWithSome + (compact, fit, inA, items, layout, not, that, will) +import TestJustAbitToLongModuleNameLikeThisOneIs () +import TestJustShortEnoughModuleNameLikeThisOne () diff --git a/data/Test477.hs b/data/Test477.hs new file mode 100644 index 0000000..0f32c77 --- /dev/null +++ b/data/Test477.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLikeThisOn as T diff --git a/data/Test478.hs b/data/Test478.hs new file mode 100644 index 0000000..3c047b9 --- /dev/null +++ b/data/Test478.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import TestJustAbitToLongModuleNameLikeTh hiding () +import TestJustShortEnoughModuleNameLike hiding () diff --git a/data/Test479.hs b/data/Test479.hs new file mode 100644 index 0000000..3e8adc0 --- /dev/null +++ b/data/Test479.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import MoreThanSufficientlyLongModuleNameWithSome + (compact, fit, inA, items, layout, not, that, will) diff --git a/data/Test48.hs b/data/Test48.hs new file mode 100644 index 0000000..56c5cba --- /dev/null +++ b/data/Test48.hs @@ -0,0 +1,4 @@ +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } diff --git a/data/Test480.hs b/data/Test480.hs new file mode 100644 index 0000000..4bc1c0c --- /dev/null +++ b/data/Test480.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) diff --git a/data/Test481.hs b/data/Test481.hs new file mode 100644 index 0000000..b6f7509 --- /dev/null +++ b/data/Test481.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} diff --git a/data/Test482.hs b/data/Test482.hs new file mode 100644 index 0000000..4fd065e --- /dev/null +++ b/data/Test482.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( abc + , def + -- comment + ) diff --git a/data/Test483.hs b/data/Test483.hs new file mode 100644 index 0000000..5a03da5 --- /dev/null +++ b/data/Test483.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( abc + -- comment + ) diff --git a/data/Test484.hs b/data/Test484.hs new file mode 100644 index 0000000..7749c61 --- /dev/null +++ b/data/Test484.hs @@ -0,0 +1,12 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) +-- Test +import Test (test) diff --git a/data/Test485.hs b/data/Test485.hs new file mode 100644 index 0000000..a1879a2 --- /dev/null +++ b/data/Test485.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( -- comment + ) diff --git a/data/Test486.hs b/data/Test486.hs new file mode 100644 index 0000000..e66d47a --- /dev/null +++ b/data/Test486.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test (longbindingNameThatoverflowsColum) +import Test (Long(List, Of, Things)) diff --git a/data/Test487.hs b/data/Test487.hs new file mode 100644 index 0000000..4fa860d --- /dev/null +++ b/data/Test487.hs @@ -0,0 +1,27 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import Test + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +import Test + ( Thing + ( Item + -- and Comment + ) + ) +import Test + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) + ) diff --git a/data/Test488.hs b/data/Test488.hs new file mode 100644 index 0000000..f65f0d6 --- /dev/null +++ b/data/Test488.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + () diff --git a/data/Test489.hs b/data/Test489.hs new file mode 100644 index 0000000..f16fa76 --- /dev/null +++ b/data/Test489.hs @@ -0,0 +1,25 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE BangPatterns #-} +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ) where +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} +-- Test +import Test (test) diff --git a/data/Test49.hs b/data/Test49.hs new file mode 100644 index 0000000..3b236c6 --- /dev/null +++ b/data/Test49.hs @@ -0,0 +1,5 @@ +data Foo = Bar + { fooz :: Baz + , bar :: Bizzz + } + deriving Show diff --git a/data/Test490.hs b/data/Test490.hs new file mode 100644 index 0000000..0cf1f73 --- /dev/null +++ b/data/Test490.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + abc <- foo +--abc +return () diff --git a/data/Test491.hs b/data/Test491.hs new file mode 100644 index 0000000..b625fed --- /dev/null +++ b/data/Test491.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = (()) diff --git a/data/Test492.hs b/data/Test492.hs new file mode 100644 index 0000000..2585e2d --- /dev/null +++ b/data/Test492.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + foo True = True + foo _ = False + return () diff --git a/data/Test493.hs b/data/Test493.hs new file mode 100644 index 0000000..2585e2d --- /dev/null +++ b/data/Test493.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + foo True = True + foo _ = False + return () diff --git a/data/Test494.hs b/data/Test494.hs new file mode 100644 index 0000000..872a368 --- /dev/null +++ b/data/Test494.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + foo = True + b = False + return () diff --git a/data/Test495.hs b/data/Test495.hs new file mode 100644 index 0000000..43d52fe --- /dev/null +++ b/data/Test495.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + let + foo = True + b = False + in return () diff --git a/data/Test496.hs b/data/Test496.hs new file mode 100644 index 0000000..d06ea75 --- /dev/null +++ b/data/Test496.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } diff --git a/data/Test497.hs b/data/Test497.hs new file mode 100644 index 0000000..f862333 --- /dev/null +++ b/data/Test497.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent state + , _lstate_foo = _lstate_foo state + } diff --git a/data/Test498.hs b/data/Test498.hs new file mode 100644 index 0000000..52505be --- /dev/null +++ b/data/Test498.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo kasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test499.hs b/data/Test499.hs new file mode 100644 index 0000000..7362219 --- /dev/null +++ b/data/Test499.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = Foo { _lstate_indent = _lstate_indent state } diff --git a/data/Test5.hs b/data/Test5.hs new file mode 100644 index 0000000..71a352d --- /dev/null +++ b/data/Test5.hs @@ -0,0 +1 @@ +func :: (a -> a) -> a diff --git a/data/Test50.hs b/data/Test50.hs new file mode 100644 index 0000000..f249e56 --- /dev/null +++ b/data/Test50.hs @@ -0,0 +1,8 @@ +data MyRecord = MyConstructor + { bar1, bar2 + :: Loooooooooooooooooooooooooooooooong + -> Loooooooooooooooooooooooooooooooong + , foo1, foo2 + :: Loooooooooooooooooooooooooooooooonger + -> Loooooooooooooooooooooooooooooooonger + } diff --git a/data/Test500.hs b/data/Test500.hs new file mode 100644 index 0000000..9b188e5 --- /dev/null +++ b/data/Test500.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test501.hs b/data/Test501.hs new file mode 100644 index 0000000..1cac41f --- /dev/null +++ b/data/Test501.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + Foo + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } diff --git a/data/Test502.hs b/data/Test502.hs new file mode 100644 index 0000000..2482992 --- /dev/null +++ b/data/Test502.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do +-- abc + -- def + return () diff --git a/data/Test503.hs b/data/Test503.hs new file mode 100644 index 0000000..36aa1f1 --- /dev/null +++ b/data/Test503.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + do + return () + -- abc + -- def + return () diff --git a/data/Test504.hs b/data/Test504.hs new file mode 100644 index 0000000..3c3d575 --- /dev/null +++ b/data/Test504.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func + :: Int -- basic indentation amount + -> Int -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + -> LayoutDesc + -> Int diff --git a/data/Test505.hs b/data/Test505.hs new file mode 100644 index 0000000..0157f35 --- /dev/null +++ b/data/Test505.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + $ abc + $ def + $ ghi + $ jkl + ) diff --git a/data/Test506.hs b/data/Test506.hs new file mode 100644 index 0000000..ed27504 --- /dev/null +++ b/data/Test506.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where reassoc (v, e, w) = (v, (e, w)) diff --git a/data/Test507.hs b/data/Test507.hs new file mode 100644 index 0000000..1795543 --- /dev/null +++ b/data/Test507.hs @@ -0,0 +1,5 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +downloadRepoPackage = case repo of + RepoLocal {..} -> return () + RepoLocal { abc } -> return () + RepoLocal{} -> return () diff --git a/data/Test508.hs b/data/Test508.hs new file mode 100644 index 0000000..5ecfcc9 --- /dev/null +++ b/data/Test508.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + let + (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' + (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' + -- default local dir target if there's no given target + utargets'' = "foo" + return () diff --git a/data/Test509.hs b/data/Test509.hs new file mode 100644 index 0000000..f66ac30 --- /dev/null +++ b/data/Test509.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + [ (thing, take 10 alts) --TODO: select best ones + | (thing, _got, alts@(_ : _)) <- nosuchFooThing + , gast <- award + ] diff --git a/data/Test51.hs b/data/Test51.hs new file mode 100644 index 0000000..ba064e1 --- /dev/null +++ b/data/Test51.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DatatypeContexts #-} +data + ( LooooooooooooooooooooongConstraint a + , LooooooooooooooooooooongConstraint b + ) => + MyRecord a b + = MyConstructor + { foo1, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } diff --git a/data/Test510.hs b/data/Test510.hs new file mode 100644 index 0000000..e939f8f --- /dev/null +++ b/data/Test510.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = if x + then if y -- y is important + then foo + else bar + else Nothing diff --git a/data/Test511.hs b/data/Test511.hs new file mode 100644 index 0000000..fcc4b7c --- /dev/null +++ b/data/Test511.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return $ Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR diff --git a/data/Test512.hs b/data/Test512.hs new file mode 100644 index 0000000..721607a --- /dev/null +++ b/data/Test512.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +layoutWriteNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () diff --git a/data/Test513.hs b/data/Test513.hs new file mode 100644 index 0000000..19308aa --- /dev/null +++ b/data/Test513.hs @@ -0,0 +1,25 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +readMergePersConfig path shouldCreate conf = do + exists <- liftIO $ System.Directory.doesFileExist path + if + | exists -> do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn e + mzero + Right x -> return x + return $ fileConf Semigroup.<> conf + | shouldCreate -> do + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Option . Just . runIdentity) + staticDefaultConfig + return $ conf + | otherwise -> do + return conf diff --git a/data/Test514.hs b/data/Test514.hs new file mode 100644 index 0000000..8dcc5a1 --- /dev/null +++ b/data/Test514.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _) -> InstallOk diff --git a/data/Test515.hs b/data/Test515.hs new file mode 100644 index 0000000..8dcc5a1 --- /dev/null +++ b/data/Test515.hs @@ -0,0 +1,13 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _) -> InstallOk diff --git a/data/Test516.hs b/data/Test516.hs new file mode 100644 index 0000000..ccf86e7 --- /dev/null +++ b/data/Test516.hs @@ -0,0 +1,37 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +showPackageDetailedInfo pkginfo = + renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) + $ char '*' + $+$ something + [ entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry + "Versions available" + sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry + "Versions installed" + installedVersions + (altText + null + (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") + ) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) + then empty + else text "Modules:" + $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ] diff --git a/data/Test517.hs b/data/Test517.hs new file mode 100644 index 0000000..5b5926c --- /dev/null +++ b/data/Test517.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +isValidPosition position + | validX && validY = Just position + | otherwise = Nothing diff --git a/data/Test518.hs b/data/Test518.hs new file mode 100644 index 0000000..5583847 --- /dev/null +++ b/data/Test518.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do + (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String + -> IO Bool) <- + ReflexHost.newExternalEvent + liftIO . forkIO . forever $ getLine >>= inputFire + ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent diff --git a/data/Test519.hs b/data/Test519.hs new file mode 100644 index 0000000..88cd872 --- /dev/null +++ b/data/Test519.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +-- Test.hs +module Test where +data X = X diff --git a/data/Test52.hs b/data/Test52.hs new file mode 100644 index 0000000..a8b49da --- /dev/null +++ b/data/Test52.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => Bar + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } diff --git a/data/Test520.hs b/data/Test520.hs new file mode 100644 index 0000000..d9dac4b --- /dev/null +++ b/data/Test520.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foldrDesc f z = unSwitchQueue $ \q -> + switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/data/Test521.hs b/data/Test521.hs new file mode 100644 index 0000000..ff6208b --- /dev/null +++ b/data/Test521.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +autocheckCases = + [ ("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions", representative exceptionsNever) + , ("Consistent Result", alwaysSame) -- already representative + ] diff --git a/data/Test522.hs b/data/Test522.hs new file mode 100644 index 0000000..d3c2fb0 --- /dev/null +++ b/data/Test522.hs @@ -0,0 +1,8 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +autocheckCases = + [ ("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions", representative exceptionsNever) + , ( "Consistent Result" + , alwaysSame -- already representative + ) + ] diff --git a/data/Test523.hs b/data/Test523.hs new file mode 100644 index 0000000..78897cd --- /dev/null +++ b/data/Test523.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + [ (abc, (1111, 1111)) + , (def, (2, 2)) + , foo -- comment + ] diff --git a/data/Test524.hs b/data/Test524.hs new file mode 100644 index 0000000..0aeb4a8 --- /dev/null +++ b/data/Test524.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + where g a b = b + b * a diff --git a/data/Test525.hs b/data/Test525.hs new file mode 100644 index 0000000..74d9df7 --- /dev/null +++ b/data/Test525.hs @@ -0,0 +1,2 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo diff --git a/data/Test526.hs b/data/Test526.hs new file mode 100644 index 0000000..ae6bb6a --- /dev/null +++ b/data/Test526.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = do + abc <- expr + abcccccccccccccccccc <- expr + abcccccccccccccccccccccccccccccccccccccccccc <- expr + abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr diff --git a/data/Test527.hs b/data/Test527.hs new file mode 100644 index 0000000..f3664cd --- /dev/null +++ b/data/Test527.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func (MyLongFoo abc def) = 1 +func (Bar a d) = 2 +func _ = 3 diff --git a/data/Test528.hs b/data/Test528.hs new file mode 100644 index 0000000..2867ab4 --- /dev/null +++ b/data/Test528.hs @@ -0,0 +1,15 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +parserCompactLocation = + [ try + $ [ ParseRelAbs (Text.Read.read digits) _ _ + | digits <- many1 digit + , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe + [ case divPart of + Nothing -> Left $ Text.Read.read digits + Just ddigits -> + Right $ Text.Read.read digits % Text.Read.read ddigits + | digits <- many1 digit + , divPart <- optionMaybe (string "/" *> many1 digit) + ] + ] + ] diff --git a/data/Test529.hs b/data/Test529.hs new file mode 100644 index 0000000..f2b42a8 --- /dev/null +++ b/data/Test529.hs @@ -0,0 +1,4 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test53.hs b/data/Test53.hs new file mode 100644 index 0000000..82be3f3 --- /dev/null +++ b/data/Test53.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a + . LooooooooooooooooooooongConstraint a => + LoooooooooooongConstructor + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } diff --git a/data/Test530.hs b/data/Test530.hs new file mode 100644 index 0000000..ae12740 --- /dev/null +++ b/data/Test530.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = + fooooooooooooooooooooooooooooooooo + + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo diff --git a/data/Test531.hs b/data/Test531.hs new file mode 100644 index 0000000..fc1335c --- /dev/null +++ b/data/Test531.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + [ foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + ] diff --git a/data/Test532.hs b/data/Test532.hs new file mode 100644 index 0000000..fcda0ed --- /dev/null +++ b/data/Test532.hs @@ -0,0 +1,20 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +parserPrim = + [ r + | r <- + [ SGPPrimFloat $ bool id (0 -) minus $ readGnok + "parserPrim" + (d1 ++ d2 ++ d3 ++ d4) + | d2 <- string "." + , d3 <- many1 (oneOf "0123456789") + , _ <- string "f" + ] + <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "f" + ] + <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "i" + ] + ] diff --git a/data/Test533.hs b/data/Test533.hs new file mode 100644 index 0000000..3f54efe --- /dev/null +++ b/data/Test533.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +samples = (SV.unpackaaaaadat) <&> \f -> + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test534.hs b/data/Test534.hs new file mode 100644 index 0000000..33c5182 --- /dev/null +++ b/data/Test534.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +runBrittany tabSize text = do + let + config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text diff --git a/data/Test535.hs b/data/Test535.hs new file mode 100644 index 0000000..cb2da37 --- /dev/null +++ b/data/Test535.hs @@ -0,0 +1,3 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE TypeApplications #-} +foo = bar @Baz diff --git a/data/Test536.hs b/data/Test536.hs new file mode 100644 index 0000000..8674ebf --- /dev/null +++ b/data/Test536.hs @@ -0,0 +1,51 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE TypeApplications #-} +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do + docAlt + $ -- one-line solution + [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart + ] + ] + | not hasComments + , [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> [] + ] + ++ -- one-line solution + where in next line(s) + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , Data.Maybe.isJust mWhereDocs + ] + ++ -- two-line solution + where in next line(s) + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] diff --git a/data/Test537.hs b/data/Test537.hs new file mode 100644 index 0000000..12526a2 --- /dev/null +++ b/data/Test537.hs @@ -0,0 +1,11 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE MultiWayIf #-} +func = do + let + foo = if + | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO + -> max + (defLen - 0.2) -- TODO + (defLen * 0.8) + | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO + return True diff --git a/data/Test538.hs b/data/Test538.hs new file mode 100644 index 0000000..a527909 --- /dev/null +++ b/data/Test538.hs @@ -0,0 +1,6 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +foo n = case n of + 1 -> True + -1 -> False +bar n = case n of + (-2, -2) -> (-2, -2) diff --git a/data/Test539.hs b/data/Test539.hs new file mode 100644 index 0000000..7da39e1 --- /dev/null +++ b/data/Test539.hs @@ -0,0 +1,7 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +{-# LANGUAGE TypeApplications #-} +foo = + let + a = b @1 + cccc = () + in foo diff --git a/data/Test54.hs b/data/Test54.hs new file mode 100644 index 0000000..7d2cb1b --- /dev/null +++ b/data/Test54.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { a :: a + , b :: b + } diff --git a/data/Test540.hs b/data/Test540.hs new file mode 100644 index 0000000..936c1cd --- /dev/null +++ b/data/Test540.hs @@ -0,0 +1,14 @@ +-- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } +record :: Record +record = Record + { rProperties = + [ "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + , "foo" .= "bar" + ] + } diff --git a/data/Test55.hs b/data/Test55.hs new file mode 100644 index 0000000..e49c0da --- /dev/null +++ b/data/Test55.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyStruct + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) diff --git a/data/Test56.hs b/data/Test56.hs new file mode 100644 index 0000000..941107b --- /dev/null +++ b/data/Test56.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { foo, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + deriving Show diff --git a/data/Test57.hs b/data/Test57.hs new file mode 100644 index 0000000..6bcfc1b --- /dev/null +++ b/data/Test57.hs @@ -0,0 +1,5 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test58.hs b/data/Test58.hs new file mode 100644 index 0000000..6b228a2 --- /dev/null +++ b/data/Test58.hs @@ -0,0 +1,12 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving Show + deriving (Eq, Ord) + deriving stock Show + deriving stock (Eq, Ord) + deriving anyclass Show + deriving anyclass (Show, Eq, Monad, Functor) + deriving newtype Show + deriving newtype (Traversable, Foldable) diff --git a/data/Test59.hs b/data/Test59.hs new file mode 100644 index 0000000..5721ef0 --- /dev/null +++ b/data/Test59.hs @@ -0,0 +1,6 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving ToJSON via (SomeType) + deriving (ToJSON, FromJSON) via (SomeType) diff --git a/data/Test6.hs b/data/Test6.hs new file mode 100644 index 0000000..9bf7bb6 --- /dev/null +++ b/data/Test6.hs @@ -0,0 +1 @@ +func :: a -> (a -> a) diff --git a/data/Test60.hs b/data/Test60.hs new file mode 100644 index 0000000..79ccc7a --- /dev/null +++ b/data/Test60.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} +data Foo = forall a . Show a => Bar + { foo :: a + } diff --git a/data/Test61.hs b/data/Test61.hs new file mode 100644 index 0000000..81d41bf --- /dev/null +++ b/data/Test61.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExistentialQuantification #-} +data Foo = forall a b . (Show a, Eq b) => Bar + { foo :: a + , bars :: b + } diff --git a/data/Test62.hs b/data/Test62.hs new file mode 100644 index 0000000..8762559 --- /dev/null +++ b/data/Test62.hs @@ -0,0 +1,3 @@ +-- before +data MyData = MyData Int +-- after diff --git a/data/Test63.hs b/data/Test63.hs new file mode 100644 index 0000000..5532f33 --- /dev/null +++ b/data/Test63.hs @@ -0,0 +1,5 @@ +data MyRecord = MyRecord + { a :: Int + -- comment + , b :: Int + } diff --git a/data/Test64.hs b/data/Test64.hs new file mode 100644 index 0000000..0d37152 --- /dev/null +++ b/data/Test64.hs @@ -0,0 +1,5 @@ +data Foo = Bar -- a + { foo :: Baz -- b + , bars :: Bizzz -- c + } -- d + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e diff --git a/data/Test65.hs b/data/Test65.hs new file mode 100644 index 0000000..dd2506f --- /dev/null +++ b/data/Test65.hs @@ -0,0 +1,9 @@ +data Foo = Bar + { -- a + foo -- b + :: -- c + Baz -- d + , -- e + bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test66.hs b/data/Test66.hs new file mode 100644 index 0000000..3c7aeaa --- /dev/null +++ b/data/Test66.hs @@ -0,0 +1,11 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --b + ( -- c + ToJSON -- d + , -- e + FromJSON --f + ) -- g diff --git a/data/Test67.hs b/data/Test67.hs new file mode 100644 index 0000000..a3a915b --- /dev/null +++ b/data/Test67.hs @@ -0,0 +1,13 @@ +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --a + ToJSON --b + via -- c + ( -- d + SomeType --e + , -- f + ABC --g + ) diff --git a/data/Test68.hs b/data/Test68.hs new file mode 100644 index 0000000..0375bbb --- /dev/null +++ b/data/Test68.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} +data MyRecord + -- test comment + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor a b diff --git a/data/Test69.hs b/data/Test69.hs new file mode 100644 index 0000000..a1759f1 --- /dev/null +++ b/data/Test69.hs @@ -0,0 +1,4 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyLeft } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test7.hs b/data/Test7.hs new file mode 100644 index 0000000..6fd2b47 --- /dev/null +++ b/data/Test7.hs @@ -0,0 +1,2 @@ +func :: (((((((((()))))))))) +-- current output is.. funny. wonder if that can/needs to be improved.. diff --git a/data/Test70.hs b/data/Test70.hs new file mode 100644 index 0000000..a2147f6 --- /dev/null +++ b/data/Test70.hs @@ -0,0 +1,3 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test71.hs b/data/Test71.hs new file mode 100644 index 0000000..5de2318 --- /dev/null +++ b/data/Test71.hs @@ -0,0 +1,4 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test72.hs b/data/Test72.hs new file mode 100644 index 0000000..af66351 --- /dev/null +++ b/data/Test72.hs @@ -0,0 +1,3 @@ +-- brittany {lconfig_indentPolicy: IndentPolicyMultiple } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] diff --git a/data/Test73.hs b/data/Test73.hs new file mode 100644 index 0000000..260d671 --- /dev/null +++ b/data/Test73.hs @@ -0,0 +1,22 @@ +data XIILqcacwiuNiu = XIILqcacwiuNiu + { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo + , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] + , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo + , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo + , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int + , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq + , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq + , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo + , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn + , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo + , opjUxtkxzkiKse_luqjuZazt + :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] + -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () + , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo + , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn + , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn + , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn + , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn + , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep + , jeyOcuesexaYoy_vpqn :: Jgtoyuh () + } diff --git a/data/Test74.hs b/data/Test74.hs new file mode 100644 index 0000000..e9e6d4f --- /dev/null +++ b/data/Test74.hs @@ -0,0 +1 @@ +func x = x diff --git a/data/Test75.hs b/data/Test75.hs new file mode 100644 index 0000000..2e7361d --- /dev/null +++ b/data/Test75.hs @@ -0,0 +1 @@ +x *** y = x diff --git a/data/Test76.hs b/data/Test76.hs new file mode 100644 index 0000000..877399e --- /dev/null +++ b/data/Test76.hs @@ -0,0 +1 @@ +(***) x y = x diff --git a/data/Test77.hs b/data/Test77.hs new file mode 100644 index 0000000..b0795a1 --- /dev/null +++ b/data/Test77.hs @@ -0,0 +1 @@ +(f >=> g) k = f k >>= g diff --git a/data/Test78.hs b/data/Test78.hs new file mode 100644 index 0000000..1f3d4e7 --- /dev/null +++ b/data/Test78.hs @@ -0,0 +1,4 @@ +(Left a <$$> Left dd) e f = True +(Left a <$$> Right d ) e f = True +(Right a <$$> Left d ) e f = False +(Right a <$$> Right dd) e f = True diff --git a/data/Test79.hs b/data/Test79.hs new file mode 100644 index 0000000..bc6cbe5 --- /dev/null +++ b/data/Test79.hs @@ -0,0 +1 @@ +func _ = x diff --git a/data/Test8.hs b/data/Test8.hs new file mode 100644 index 0000000..9b1b57b --- /dev/null +++ b/data/Test8.hs @@ -0,0 +1 @@ +func :: () diff --git a/data/Test80.hs b/data/Test80.hs new file mode 100644 index 0000000..5c29c83 --- /dev/null +++ b/data/Test80.hs @@ -0,0 +1,2 @@ +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = + x diff --git a/data/Test81.hs b/data/Test81.hs new file mode 100644 index 0000000..7649b18 --- /dev/null +++ b/data/Test81.hs @@ -0,0 +1,2 @@ +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x diff --git a/data/Test82.hs b/data/Test82.hs new file mode 100644 index 0000000..dcb58cf --- /dev/null +++ b/data/Test82.hs @@ -0,0 +1,2 @@ +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b + = x diff --git a/data/Test83.hs b/data/Test83.hs new file mode 100644 index 0000000..2e709c1 --- /dev/null +++ b/data/Test83.hs @@ -0,0 +1 @@ +func (A a) = a diff --git a/data/Test84.hs b/data/Test84.hs new file mode 100644 index 0000000..58f9aca --- /dev/null +++ b/data/Test84.hs @@ -0,0 +1 @@ +func (x : xr) = x diff --git a/data/Test85.hs b/data/Test85.hs new file mode 100644 index 0000000..f097653 --- /dev/null +++ b/data/Test85.hs @@ -0,0 +1 @@ +func (x :+: xr) = x diff --git a/data/Test86.hs b/data/Test86.hs new file mode 100644 index 0000000..f5eccc0 --- /dev/null +++ b/data/Test86.hs @@ -0,0 +1 @@ +func (x `Foo` xr) = x diff --git a/data/Test87.hs b/data/Test87.hs new file mode 100644 index 0000000..5a64709 --- /dev/null +++ b/data/Test87.hs @@ -0,0 +1 @@ +func | True = x diff --git a/data/Test88.hs b/data/Test88.hs new file mode 100644 index 0000000..ca71136 --- /dev/null +++ b/data/Test88.hs @@ -0,0 +1,2 @@ +func x | x = simple expression + | otherwise = 0 diff --git a/data/Test89.hs b/data/Test89.hs new file mode 100644 index 0000000..c18a534 --- /dev/null +++ b/data/Test89.hs @@ -0,0 +1,3 @@ +func x + | a somewhat longer guard x = "and a somewhat longer expession that does not" + | otherwise = "fit without putting the guards in new lines" diff --git a/data/Test9.hs b/data/Test9.hs new file mode 100644 index 0000000..1b64914 --- /dev/null +++ b/data/Test9.hs @@ -0,0 +1,5 @@ +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + ) diff --git a/data/Test90.hs b/data/Test90.hs new file mode 100644 index 0000000..6f9ef8f --- /dev/null +++ b/data/Test90.hs @@ -0,0 +1,7 @@ +func x + | very long guard, another rather long guard that refers to x = nontrivial + expression + foo + bar + alsdkjlasdjlasj + | otherwise = 0 diff --git a/data/Test91.hs b/data/Test91.hs new file mode 100644 index 0000000..9256c3f --- /dev/null +++ b/data/Test91.hs @@ -0,0 +1,5 @@ +func x + | very long guard, another rather long guard that refers to x + = nontrivialexpression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test92.hs b/data/Test92.hs new file mode 100644 index 0000000..289aa8b --- /dev/null +++ b/data/Test92.hs @@ -0,0 +1,6 @@ +func x + | very loooooooooooooooooooooooooooooong guard + , another rather long guard that refers to x + = nontrivial expression foo bar alsdkjlasdjlasj + | otherwise + = 0 diff --git a/data/Test93.hs b/data/Test93.hs new file mode 100644 index 0000000..48053a4 --- /dev/null +++ b/data/Test93.hs @@ -0,0 +1,2 @@ +func = x +describe "infix op" $ do diff --git a/data/Test94.hs b/data/Test94.hs new file mode 100644 index 0000000..aa1fd8f --- /dev/null +++ b/data/Test94.hs @@ -0,0 +1 @@ +func = x + x diff --git a/data/Test95.hs b/data/Test95.hs new file mode 100644 index 0000000..2d99eaf --- /dev/null +++ b/data/Test95.hs @@ -0,0 +1,3 @@ +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test96.hs b/data/Test96.hs new file mode 100644 index 0000000..d9a2015 --- /dev/null +++ b/data/Test96.hs @@ -0,0 +1,4 @@ +func = + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj diff --git a/data/Test97.hs b/data/Test97.hs new file mode 100644 index 0000000..094383e --- /dev/null +++ b/data/Test97.hs @@ -0,0 +1,4 @@ +func = + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test98.hs b/data/Test98.hs new file mode 100644 index 0000000..cc29546 --- /dev/null +++ b/data/Test98.hs @@ -0,0 +1,5 @@ +func = 1 +func = "abc" +func = 1.1e5 +func = 'x' +func = 981409823458910394810928414192837123987123987123 diff --git a/data/Test99.hs b/data/Test99.hs new file mode 100644 index 0000000..efcec60 --- /dev/null +++ b/data/Test99.hs @@ -0,0 +1,2 @@ +func = \x -> abc +describe "app" $ do diff --git a/data/brittany.yaml b/data/brittany.yaml new file mode 100644 index 0000000..b9b9aab --- /dev/null +++ b/data/brittany.yaml @@ -0,0 +1,4 @@ +conf_layout: + lconfig_allowSingleLineExportList: true + lconfig_importAsColumn: 60 + lconfig_importColumn: 60 diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index c32f1f7..ca9fc7b 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -31,6 +31,7 @@ import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Paths_brittany import qualified System.Directory as Directory +import qualified System.Environment as Environment import qualified System.Exit import qualified System.FilePath.Posix as FilePath import qualified System.IO @@ -54,7 +55,16 @@ instance Show WriteMode where main :: IO () -main = mainFromCmdParserWithHelpDesc mainCmdParser +main = do + progName <- Environment.getProgName + args <- Environment.getArgs + mainWith progName args + +mainWith :: String -> [String] -> IO () +mainWith progName args = + Environment.withProgName progName + . Environment.withArgs args + $ mainFromCmdParserWithHelpDesc mainCmdParser helpDoc :: PP.Doc helpDoc = PP.vcat $ List.intersperse diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 36e79ef..c8324df 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -1,256 +1,50 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE ScopedTypeVariables #-} - -import Data.Coerce (coerce) -import Data.List (groupBy) -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified System.Directory -import System.FilePath (()) -import System.Timeout (timeout) -import Test.Hspec -import qualified Text.Parsec as Parsec -import Text.Parsec.Text (Parser) - -hush :: Either a b -> Maybe b -hush = either (const Nothing) Just - - - -asymptoticPerfTest :: Spec -asymptoticPerfTest = do - it "10 do statements" - $ roundTripEqualWithTimeout 1500000 - $ (Text.pack "func = do\n") - <> Text.replicate 10 (Text.pack " statement\n") - it "10 do nestings" - $ roundTripEqualWithTimeout 4000000 - $ (Text.pack "func = ") - <> mconcat - ( [1 .. 10] - <&> \(i :: Int) -> - (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") - ) - <> Text.replicate 2000 (Text.pack " ") - <> Text.pack "return\n" - <> Text.replicate 2002 (Text.pack " ") - <> Text.pack "()" - it "10 AppOps" - $ roundTripEqualWithTimeout 1000000 - $ (Text.pack "func = expr") - <> Text.replicate 10 (Text.pack "\n . expr") --TODO - -roundTripEqualWithTimeout :: Int -> Text -> Expectation -roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) - where - action = fmap (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) - - -data InputLine - = GroupLine Text - | HeaderLine Text - | PendingLine - | NormalLine Text - | CommentLine - deriving Show - -data TestCase = TestCase - { testName :: Text - , isPending :: Bool - , content :: Text - } +import qualified Control.Exception as Exception +import qualified Control.Monad as Monad +import qualified Data.List as List +import qualified Language.Haskell.Brittany.Main as Brittany +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified System.IO as IO +import qualified Test.Hspec as Hspec main :: IO () -main = do - files <- System.Directory.listDirectory "data/" - let blts = - List.sort - $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt" `isSuffixOf`) files - inputs <- blts `forM` \blt -> Text.IO.readFile ("data" blt) - let groups = createChunks =<< inputs - inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt" - let groupsCtxFree = createChunks inputCtxFree - hspec $ do - describe "asymptotic perf roundtrips" $ asymptoticPerfTest - describe "library interface basic functionality" $ do - it "gives properly formatted result for valid input" $ do - let - input = Text.pack $ unlines - ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] - let expected = Text.pack $ unlines - [ "func =" - , " [ 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " ]" - ] - output <- liftIO $ parsePrintModule staticDefaultConfig input - hush output `shouldBe` Just expected - groups `forM_` \(groupname, tests) -> do - describe (Text.unpack groupname) $ do - tests `forM_` \test -> do - (if isPending test then before_ pending else id) - $ it (Text.unpack $ testName test) - $ roundTripEqual defaultTestConfig - $ content test - groupsCtxFree `forM_` \(groupname, tests) -> do - describe ("context free: " ++ Text.unpack groupname) $ do - tests `forM_` \test -> do - (if isPending test then before_ pending else id) - $ it (Text.unpack $ testName test) - $ roundTripEqual contextFreeTestConfig - $ content test - where - -- this function might be implemented in a weirdly complex fashion; the - -- reason being that it was copied from a somewhat more complex variant. - createChunks :: Text -> [(Text, [TestCase])] - createChunks input = --- fmap (\case --- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines) --- HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines) --- l -> error $ "first non-empty line must start with #test footest\n" ++ show l --- ) --- $ fmap (groupBy grouperT) - fmap groupProcessor - $ groupBy grouperG - $ filter (not . lineIsSpace) - $ lineMapper - <$> Text.lines input - where - groupProcessor :: [InputLine] -> (Text, [TestCase]) - groupProcessor = \case - GroupLine g : grouprest -> - (,) g - $ fmap testProcessor - $ groupBy grouperT - $ filter (not . lineIsSpace) - $ grouprest - l -> error $ "first non-empty line must be a #group\n" ++ show l - testProcessor :: [InputLine] -> TestCase - testProcessor = \case - HeaderLine n : rest -> - let normalLines = Data.Maybe.mapMaybe extractNormal rest - in TestCase - { testName = n - , isPending = any isPendingLine rest - , content = Text.unlines normalLines - } - l -> - error $ "first non-empty line must start with #test footest\n" ++ show l - extractNormal (NormalLine l) = Just l - extractNormal _ = Nothing - isPendingLine PendingLine{} = True - isPendingLine _ = False - specialLineParser :: Parser InputLine - specialLineParser = Parsec.choice - [ [ GroupLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#group" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" - , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof - ] - , [ HeaderLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#test" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" - , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof - ] - , [ PendingLine - | _ <- Parsec.try $ Parsec.string "#pending" - , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") - , _ <- Parsec.eof - ] - , [ CommentLine - | _ <- Parsec.many $ Parsec.oneOf " \t" - , _ <- Parsec.optional $ Parsec.string "##" <* many - (Parsec.noneOf "\r\n") - , _ <- Parsec.eof - ] - , [ NormalLine mempty - | _ <- Parsec.try $ Parsec.string "" - , _ <- Parsec.eof - ] - ] - lineMapper :: Text -> InputLine - lineMapper line = case Parsec.runParser specialLineParser () "" line of - Left _e -> NormalLine line - Right l -> l - lineIsSpace :: InputLine -> Bool - lineIsSpace CommentLine = True - lineIsSpace _ = False - grouperG :: InputLine -> InputLine -> Bool - grouperG _ GroupLine{} = False - grouperG _ _ = True - grouperT :: InputLine -> InputLine -> Bool - grouperT _ HeaderLine{} = False - grouperT _ _ = True +main = Hspec.hspec . Hspec.parallel $ do + let directory = "data" + entries <- Hspec.runIO $ Directory.listDirectory directory + Monad.forM_ (List.sort entries) $ \entry -> + case FilePath.stripExtension "hs" entry of + Nothing -> pure () + Just slug -> Hspec.it slug $ do + let input = FilePath.combine directory entry + expected <- readFile input + actual <- withTemporaryFile $ \output handle -> do + IO.hClose handle + Directory.copyFile input output + Brittany.mainWith + "brittany" + [ "--config-file" + , FilePath.combine directory "brittany.yaml" + , "--no-user-config" + , "--write-mode" + , "inplace" + , output + ] + readFile output + Literal actual `Hspec.shouldBe` Literal expected +withTemporaryFile :: (FilePath -> IO.Handle -> IO a) -> IO a +withTemporaryFile callback = do + directory <- Directory.getTemporaryDirectory + let + acquire = IO.openTempFile directory "brittany-.hs" + release filePath handle = do + IO.hClose handle + Directory.removeFile filePath + Exception.bracket acquire (uncurry release) (uncurry callback) --------------------- --- past this line: copy-pasta from other test (meh..) --------------------- -roundTripEqual :: Config -> Text -> Expectation -roundTripEqual c t = - fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) - `shouldReturn` Right (PPTextWrapper t) - -newtype PPTextWrapper = PPTextWrapper Text +newtype Literal + = Literal String deriving Eq -instance Show PPTextWrapper where - show (PPTextWrapper t) = "\n" ++ Text.unpack t - --- brittany-next-binding --columns 160 --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } -defaultTestConfig :: Config -defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } - , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } - -contextFreeTestConfig :: Config -contextFreeTestConfig = defaultTestConfig - { _conf_layout = (_conf_layout defaultTestConfig) - { _lconfig_indentPolicy = coerce IndentPolicyLeft - , _lconfig_alignmentLimit = coerce (1 :: Int) - , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } - } +instance Show Literal where + show (Literal x) = x -- 2.30.2 From cddb98b12471462bd8387b84eaac7f389627f6d5 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Thu, 25 Nov 2021 14:16:22 +0000 Subject: [PATCH 464/478] Run tests in serial --- source/test-suite/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index c8324df..ecc3042 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -8,7 +8,7 @@ import qualified System.IO as IO import qualified Test.Hspec as Hspec main :: IO () -main = Hspec.hspec . Hspec.parallel $ do +main = Hspec.hspec $ do let directory = "data" entries <- Hspec.runIO $ Directory.listDirectory directory Monad.forM_ (List.sort entries) $ \entry -> -- 2.30.2 From 8f2625dc87ca63629fc5413a5664fecc601d4e08 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 28 Nov 2021 13:24:11 +0000 Subject: [PATCH 465/478] Simplify test suite --- source/test-suite/Main.hs | 39 +++++++++++++-------------------------- 1 file changed, 13 insertions(+), 26 deletions(-) diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index ecc3042..e48ec56 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -1,14 +1,12 @@ -import qualified Control.Exception as Exception import qualified Control.Monad as Monad import qualified Data.List as List import qualified Language.Haskell.Brittany.Main as Brittany import qualified System.Directory as Directory import qualified System.FilePath as FilePath -import qualified System.IO as IO import qualified Test.Hspec as Hspec main :: IO () -main = Hspec.hspec $ do +main = Hspec.hspec . Hspec.parallel $ do let directory = "data" entries <- Hspec.runIO $ Directory.listDirectory directory Monad.forM_ (List.sort entries) $ \entry -> @@ -17,31 +15,20 @@ main = Hspec.hspec $ do Just slug -> Hspec.it slug $ do let input = FilePath.combine directory entry expected <- readFile input - actual <- withTemporaryFile $ \output handle -> do - IO.hClose handle - Directory.copyFile input output - Brittany.mainWith - "brittany" - [ "--config-file" - , FilePath.combine directory "brittany.yaml" - , "--no-user-config" - , "--write-mode" - , "inplace" - , output - ] - readFile output + let output = FilePath.combine "output" entry + Directory.copyFile input output + Brittany.mainWith + "brittany" + [ "--config-file" + , FilePath.combine directory "brittany.yaml" + , "--no-user-config" + , "--write-mode" + , "inplace" + , output + ] + actual <- readFile output Literal actual `Hspec.shouldBe` Literal expected -withTemporaryFile :: (FilePath -> IO.Handle -> IO a) -> IO a -withTemporaryFile callback = do - directory <- Directory.getTemporaryDirectory - let - acquire = IO.openTempFile directory "brittany-.hs" - release filePath handle = do - IO.hClose handle - Directory.removeFile filePath - Exception.bracket acquire (uncurry release) (uncurry callback) - newtype Literal = Literal String deriving Eq -- 2.30.2 From 339d2ebf23604dd410bfd1675a2c663b09364eb8 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Sun, 28 Nov 2021 14:08:58 +0000 Subject: [PATCH 466/478] Version 0.14.0.0 --- ChangeLog.md | 7 +++++++ brittany.cabal | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index c96c598..baf8314 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for brittany +## 0.14.0.0 -- November 2021 + +* #357: Added support for GHC 9.0. Dropped support for all other versions of GHC. + * ab59e9acc3069551ac4132321b285d000f5f5691: Removed runtime dependency on `ghc-paths`. + * fa8365a7fa9372043d5a1018f2f7669ce3853edd: Started providing pre-built binaries for Linux, MacOS, and Windows. + * Many other changes to Brittany's internals and exposed Haskell interface, but (hopefully) no changes to its command-line interface. + ## 0.13.1.2 -- May 2021 * #347: Allowed hspec 2.8. Thanks @felixonmars! diff --git a/brittany.cabal b/brittany.cabal index 33d760e..45b6a65 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: brittany -version: 0.13.1.2 +version: 0.14.0.0 synopsis: Haskell source code formatter description: See . -- 2.30.2 From 7fa2a85b30eff783b121115e18e3c435eb4bc681 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 29 Nov 2021 02:31:50 +0000 Subject: [PATCH 467/478] Format Brittany with Brittany Fixes #238. --- .../Language/Haskell/Brittany/Internal.hs | 442 +++--- .../Haskell/Brittany/Internal/Backend.hs | 509 +++--- .../Haskell/Brittany/Internal/BackendUtils.hs | 293 ++-- .../Haskell/Brittany/Internal/Config.hs | 232 +-- .../Haskell/Brittany/Internal/Config/Types.hs | 65 +- .../Internal/Config/Types/Instances.hs | 34 +- .../Brittany/Internal/ExactPrintUtils.hs | 87 +- .../Brittany/Internal/LayouterBasics.hs | 168 +- .../Brittany/Internal/Layouters/DataDecl.hs | 367 +++-- .../Brittany/Internal/Layouters/Decl.hs | 919 +++++------ .../Brittany/Internal/Layouters/Expr.hs | 1216 +++++++-------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 118 +- .../Brittany/Internal/Layouters/Import.hs | 169 +- .../Brittany/Internal/Layouters/Module.hs | 91 +- .../Brittany/Internal/Layouters/Pattern.hs | 81 +- .../Brittany/Internal/Layouters/Stmt.hs | 27 +- .../Brittany/Internal/Layouters/Type.hs | 418 +++-- .../Haskell/Brittany/Internal/Obfuscation.hs | 17 +- .../Haskell/Brittany/Internal/PreludeUtils.hs | 10 +- .../Brittany/Internal/Transformations/Alt.hs | 1370 +++++++++-------- .../Internal/Transformations/Columns.hs | 191 ++- .../Internal/Transformations/Floating.hs | 358 +++-- .../Internal/Transformations/Indent.hs | 20 +- .../Brittany/Internal/Transformations/Par.hs | 31 +- .../Haskell/Brittany/Internal/Utils.hs | 97 +- .../library/Language/Haskell/Brittany/Main.hs | 217 +-- 26 files changed, 3870 insertions(+), 3677 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 456ef4a..06cbb63 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -75,35 +75,36 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do [ ( k , [ x | (ExactPrint.Comment x _ _, _) <- - ( ExactPrint.annPriorComments ann + (ExactPrint.annPriorComments ann ++ ExactPrint.annFollowingComments ann ) ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] ) | (k, ann) <- Map.toList anns ] - let configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - ( ("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) + let + configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + (("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) let configParser = Butcher.addAlternatives [ ( "commandline-config" @@ -122,39 +123,44 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do ] parser = do -- we will (mis?)use butcher here to parse the inline config -- line. - let nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + let + nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + let + nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding - let disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let + disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let + disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) + let + disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do @@ -162,30 +168,31 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) Butcher.addNullCmd $ do bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser + conf <- configParser Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) conf <- configParser Butcher.addCmdImpl (InlineConfigTargetModule, conf) lineConfigss <- configLiness `forM` \(k, ss) -> do r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c + Left err -> Left $ (err, s) + Right c -> Right $ c pure (k, r) - let perModule = foldl' - (<>) - mempty - [ conf - | (_ , lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf ) <- lineConfigs - ] + let + perModule = foldl' + (<>) + mempty + [ conf + | (_, lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf) <- lineConfigs + ] let perBinding = Map.fromListWith (<>) [ (n, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs - , n <- case target of + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs + , n <- case target of InlineConfigTargetBinding s -> [s] InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> [name] @@ -195,8 +202,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do perKey = Map.fromListWith (<>) [ (k, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs , case target of InlineConfigTargetNextDecl -> True InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> @@ -214,7 +221,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls + | decl <- decls , (name : _) <- [getDeclBindingNames decl] ] @@ -232,70 +239,76 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = -- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configWithDebugs inputText = runExceptT $ do - let config = - configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let + config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack (anns, parsedSource, hasCPP) <- do - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let + hackF s = + if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s + let + hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False parseResult <- lift $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x + Left err -> throwE [ErrorInput err] + Right x -> pure x (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting then do return inputText else do (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack + let + omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConfig perItemConf anns parsedSource else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + let + hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews - , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn - (TextL.pack "\n") - outRaw + , TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw ) else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let + hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack then not $ null errsWarns else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors @@ -315,26 +328,27 @@ pPrintModule -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf inlineConf anns parsedModule = - let ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) + let + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do -- -- debugStrings `forM_` \s -> @@ -349,15 +363,17 @@ pPrintModuleAndCheck -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] + parseResult <- parseModuleFromString + ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let + errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] return (errs', output) @@ -372,18 +388,19 @@ parsePrintModuleTests conf filename input = do (const . pure $ Right ()) inputStr case parseResult of - Left err -> return $ Left err + Left err -> return $ Left err Right (anns, parsedModule, _) -> runExceptT $ do (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let + omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (errs, ltext) <- if omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift @@ -393,13 +410,13 @@ parsePrintModuleTests conf filename input = do else let errStrs = errs <&> \case - ErrorInput str -> str + ErrorInput str -> str ErrorUnusedComment str -> str - LayoutWarning str -> str + LayoutWarning str -> str ErrorUnknownNode str _ -> str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs -- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally @@ -454,25 +471,26 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl + let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk - <&> \annMap -> - Map.union defaultAnns $ - Map.findWithDefault Map.empty declAnnKey annMap + let + mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk <&> \annMap -> + Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns config <- mAsk - let config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + let + config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do @@ -487,33 +505,34 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd - let finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post + let + finalComments = filter + (fst .> \case + ExactPrint.AnnComment{} -> True + _ -> False + ) + post post `forM_` \case (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm - | span <- ExactPrint.commentIdentifier cm - -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + let + folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> + ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] + _ -> [] -- Prints the information associated with the module annotation @@ -530,8 +549,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do -- attached annotations that come after the module's where -- from the module node config <- mAsk - let shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + let + shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack let (filteredAnns', post) = @@ -541,23 +561,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do let modAnnsDp = ExactPrint.annsDP mAnn isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False + isWhere _ = False isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp (pre, post') = case (whereInd, eofInd) of (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in - (filteredAnns'', post') - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations + in (filteredAnns'', post') + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns' if shouldReformatPreamble @@ -566,7 +586,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule return post _sigHead :: Sig GhcPs -> String @@ -579,7 +599,7 @@ _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" @@ -597,63 +617,67 @@ layoutBriDoc briDoc = do transformAlts briDoc >>= mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt -- bridoc transformation: float stuff in mGet >>= transformSimplifyFloating .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating + .> traceIfDumpConf + "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating -- bridoc transformation: par removal mGet >>= transformSimplifyPar .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par -- bridoc transformation: float stuff in mGet >>= transformSimplifyColumns .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns -- bridoc transformation: indent mGet >>= transformSimplifyIndent .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl anns :: ExactPrint.Anns <- mAsk - let state = LayoutState { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } + let + state = LayoutState + { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - let remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] + let + remainingComments = + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs index 6cfbaf3..55a3c97 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -31,16 +31,20 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -type ColIndex = Int +type ColIndex = Int data ColumnSpacing = ColumnSpacingLeaf Int | ColumnSpacingRef Int Int -type ColumnBlock a = [a] +type ColumnBlock a = [a] type ColumnBlocks a = Seq [a] -type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) +type ColMap1 + = IntMapL.IntMap {- ColIndex -} + (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 + = IntMapL.IntMap {- ColIndex -} + (Float, ColumnBlock Int, ColumnBlocks Int) -- (ratio of hasSpace, maximum, raw) data ColInfo @@ -50,20 +54,23 @@ data ColInfo instance Show ColInfo where show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + show (ColInfoNo bd) = + "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") + show (ColInfo ind sig list) = + "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list data ColBuildState = ColBuildState { _cbs_map :: ColMap1 , _cbs_index :: ColIndex } -type LayoutConstraints m = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) +type LayoutConstraints m + = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM = \case @@ -84,10 +91,11 @@ layoutBriDocM = \case BDSeparator -> do layoutAddSepSpace BDAddBaseY indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ layoutBriDocM bd BDBaseYPushCur bd -> do layoutBaseYPushCur @@ -102,36 +110,39 @@ layoutBriDocM = \case layoutBriDocM bd layoutIndentLevelPop BDEnsureIndent indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteEnsureBlock layoutBriDocM bd BDPar indent sameLine indented -> do layoutBriDocM sameLine - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteNewlineBlock layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt:_) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt : _) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd BDExternal annKey subKeys shouldAddComment t -> do - let tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines + let + tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines anns :: ExactPrint.Anns <- mAsk when shouldAddComment $ do layoutWriteAppend - $ Text.pack - $ "{-" + $ Text.pack + $ "{-" ++ show (annKey, Map.lookup annKey anns) ++ "-}" zip [1 ..] tlines `forM_` \(i, l) -> do @@ -148,9 +159,10 @@ layoutBriDocM = \case BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey + let + moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -161,8 +173,8 @@ layoutBriDocM = \case } return mAnn case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace priors @@ -170,9 +182,10 @@ layoutBriDocM = \case when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y @@ -184,18 +197,20 @@ layoutBriDocM = \case layoutBriDocM bd mComments <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let mToSpan = case mAnn of - Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just - annR - _ -> Nothing + let + mToSpan = case mAnn of + Just anns | Maybe.isNothing keyword -> Just anns + Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> + Just annR + _ -> Nothing case mToSpan of Just anns -> do - let (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing + let + (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing mSet $ state { _lstate_comments = Map.adjust (\ann -> ann { ExactPrint.annsDP = rest }) @@ -207,17 +222,19 @@ layoutBriDocM = \case case mComments of Nothing -> pure () Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + -- evil hack for CPP: + case comment of + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd @@ -226,21 +243,26 @@ layoutBriDocM = \case let m = _lstate_comments state pure $ Map.lookup annKey m let mComments = nonEmpty . extractAllComments =<< annMay - let semiCount = length [ () - | Just ann <- [ annMay ] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- mAsk <&> - _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack + let + semiCount = length + [ () + | Just ann <- [annMay] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- + mAsk + <&> _conf_layout + .> _lconfig_experimentalSemicolonNewlines + .> confUnpack mModify $ \state -> state { _lstate_comments = Map.adjust - ( \ann -> ann { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = - flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } + (\ann -> ann + { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } ) annKey (_lstate_comments state) @@ -248,37 +270,40 @@ layoutBriDocM = \case case mComments of Nothing -> do when shouldAddSemicolonNewlines $ do - [1..semiCount] `forM_` const layoutWriteNewline + [1 .. semiCount] `forM_` const layoutWriteNewline Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack comment + case comment of + ('#' : _) -> layoutMoveToCommentPos y (-999) 1 + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let relevant = [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] + let + relevant = + [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] case relevant of [] -> pure Nothing - (ExactPrint.Types.DP (y, x):_) -> do + (ExactPrint.Types.DP (y, x) : _) -> do mSet state { _lstate_commentNewlines = 0 } pure $ Just (y - _lstate_commentNewlines state, x) case mDP of @@ -289,8 +314,8 @@ layoutBriDocM = \case layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" layoutBriDocM bd @@ -301,73 +326,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc -- appended at the current position. where rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc where rec :: BriDoc -> Bool rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_ ] -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= @@ -452,16 +477,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe 0 (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack case () of _ -> do -- tellDebugMess ("processedMap: " ++ show processedMap) sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos <&> processInfo colMax processedMap where (colInfos, finalState) = @@ -478,40 +503,39 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do where alignMax' = max 0 alignMax processedMap :: ColMap2 - processedMap = - fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + processedMap = fix $ \result -> + _cbs_map finalState <&> \(lastFlag, colSpacingss) -> let colss = colSpacingss <&> \spss -> case reverse spss of [] -> [] - (xN:xR) -> + (xN : xR) -> reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR where - fLast (ColumnSpacingLeaf len ) = len + fLast (ColumnSpacingLeaf len) = len fLast (ColumnSpacingRef len _) = len fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of - Nothing -> 0 + fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of + Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} fmap colAggregation $ transpose $ Foldable.toList colss (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols counter count l = if List.last posXs + List.last l <= colMax then count + 1 else count ratio = fromIntegral (foldl counter (0 :: Int) colss) / fromIntegral (length colss) - in - (ratio, maxCols, colss) + in (ratio, maxCols, colss) mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd:bdr) = do - info <- mergeInfoBriDoc True lastInfo bd + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd : bdr) = do + info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info) @@ -539,28 +563,27 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- personal preference to not break alignment for those, even if -- multiline. Really, this should be configurable.. (TODO) shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = alignBreak && - briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True + shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp{} _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True mergeInfoBriDoc :: Bool @@ -568,23 +591,22 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -> BriDoc -> StateS.StateT ColBuildState Identity ColInfo mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs - -> do + | infoSig == colSig && length subLengthsInfos == length subDocs -> do let isLastList = if lastFlag - then (==length subDocs) <$> [1 ..] + then (== length subDocs) <$> [1 ..] else repeat False infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs + let curLengths = briDocLineLength <$> subDocs let trueSpacings = getTrueSpacings (zip curLengths infos) do -- update map s <- StateS.get - let m = _cbs_map s + let m = _cbs_map s let (Just (_, spaces)) = IntMapS.lookup infoInd m StateS.put s { _cbs_map = IntMapS.insert @@ -593,17 +615,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do m } return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise - -> briDocToColInfo lastFlag brdc + | otherwise -> briDocToColInfo lastFlag brdc brdc -> return $ ColInfoNo brdc briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo lastFlag = \case BDCols sig list -> withAlloc lastFlag $ \ind -> do - let isLastList = - if lastFlag then (==length list) <$> [1 ..] else repeat False + let + isLastList = + if lastFlag then (== length list) <$> [1 ..] else repeat False subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos + let lengthInfos = zip (briDocLineLength <$> list) subInfos let trueSpacings = getTrueSpacings lengthInfos return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) bd -> return $ ColInfoNo bd @@ -611,11 +633,11 @@ briDocToColInfo lastFlag = \case getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings lengthInfos = lengthInfos <&> \case (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _ ) -> ColumnSpacingLeaf len + (len, _) -> ColumnSpacingLeaf len withAlloc :: Bool - -> ( ColIndex + -> ( ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) ) -> StateS.State ColBuildState ColInfo @@ -630,13 +652,13 @@ withAlloc lastFlag f = do processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ do colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do + curX <- do state <- mGet -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state @@ -648,10 +670,11 @@ processInfo maxSpace m = \case let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l + let + maxCols2 = list <&> \case + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l let maxCols = zipWith max maxCols1 maxCols2 let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols -- handle the cases that the vertical alignment leads to more than max @@ -662,46 +685,48 @@ processInfo maxSpace m = \case -- sizes in such a way that it works _if_ we have sizes (*factor) -- in each column. but in that line, in the last column, we will be -- forced to occupy the full vertical space, not reduced by any factor. - let fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (*factor) .> truncate - _ -> posXs - let spacings = zipWith (-) - (List.tail fixedPosXs ++ [min maxX colMax]) - fixedPosXs + let + fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (* factor) .> truncate + _ -> posXs + let + spacings = + zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs -- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct + let + alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. + then noAlignAct + else alignAct case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct processInfoIgnore :: LayoutConstraints m => ColInfo -> m () processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index 919a323..310ea56 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -22,17 +22,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -traceLocal - :: (MonadMultiState LayoutState m) - => a - -> m () +traceLocal :: (MonadMultiState LayoutState m) => a -> m () traceLocal _ = return () layoutWriteAppend - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Text -> m () layoutWriteAppend t = do @@ -48,15 +43,13 @@ layoutWriteAppend t = do mTell $ Text.Builder.fromText $ t mModify $ \s -> s { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces , _lstate_addSepSpace = Nothing } layoutWriteAppendSpaces - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () layoutWriteAppendSpaces i = do @@ -64,20 +57,18 @@ layoutWriteAppendSpaces i = do unless (i == 0) $ do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state + { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state } layoutWriteAppendMultiline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => [Text] -> m () layoutWriteAppendMultiline ts = do traceLocal ("layoutWriteAppendMultiline", ts) case ts of - [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. - (l:lr) -> do + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. + (l : lr) -> do layoutWriteAppend l lr `forM_` \x -> do layoutWriteNewline @@ -85,16 +76,15 @@ layoutWriteAppendMultiline ts = do -- adds a newline and adds spaces to reach the base column. layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteNewlineBlock = do traceLocal ("layoutWriteNewlineBlock") state <- mGet - mSet $ state { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - } + mSet $ state + { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + } -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- , MonadMultiWriter (Seq String) m) => Int -> m () @@ -110,13 +100,13 @@ layoutWriteNewlineBlock = do -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } -layoutSetCommentCol - :: (MonadMultiState LayoutState m) => m () +layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol = do state <- mGet - let col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + let + col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state traceLocal ("layoutSetCommentCol", col) unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } @@ -124,9 +114,7 @@ layoutSetCommentCol = do -- This is also used to move to non-comments in a couple of places. Seems -- to be harmless so far.. layoutMoveToCommentPos - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> Int -> Int @@ -136,38 +124,35 @@ layoutMoveToCommentPos y x commentLines = do state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y + Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = + , _lstate_addSepSpace = Just $ if Data.Maybe.isJust (_lstate_commentCol state) then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = - Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_commentCol = Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 + _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteNewline = do traceLocal ("layoutWriteNewline") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing + , _lstate_addSepSpace = Nothing } _layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () @@ -175,77 +160,66 @@ _layoutResetCommentNewlines = do mModify $ \state -> state { _lstate_commentNewlines = 0 } layoutWriteEnsureNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteEnsureNewlineBlock = do traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing } layoutWriteEnsureAbsoluteN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c , _ ) -> n - c - (Nothing, Left i ) -> n - i - (Nothing, Right{}) -> n + let + diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c, _) -> n - c + (Nothing, Left i) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to + mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to -- at least (Just 1), so we won't -- overwrite any old value in any -- bad way. - } -layoutBaseYPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () +layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m () layoutBaseYPushInternal i = do traceLocal ("layoutBaseYPushInternal", i) mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } -layoutBaseYPopInternal - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal = do traceLocal ("layoutBaseYPopInternal") mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } -layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () +layoutIndentLevelPushInternal :: (MonadMultiState LayoutState m) => Int -> m () layoutIndentLevelPushInternal i = do traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } -layoutIndentLevelPopInternal - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal = do traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } -layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () +layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger = do - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } layoutWithAddBaseCol :: ( MonadMultiWriter Text.Builder.Builder m @@ -277,9 +251,7 @@ layoutWithAddBaseColBlock m = do layoutBaseYPopInternal layoutWithAddBaseColNBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () -> m () @@ -292,27 +264,23 @@ layoutWithAddBaseColNBlock amount m = do layoutBaseYPopInternal layoutWriteEnsureBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteEnsureBlock = do traceLocal ("layoutWriteEnsureBlock") state <- mGet let diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i ) -> lstate_baseY state - i + (Nothing, Left i) -> lstate_baseY state - i (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i ) -> max sp (lstate_baseY state - i) + (Just sp, Left i) -> max sp (lstate_baseY state - i) (Just sp, Right{}) -> max sp (lstate_baseY state) -- when (diff>0) $ layoutWriteNewlineBlock when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just $ diff } layoutWithAddBaseColN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () -> m () @@ -322,39 +290,36 @@ layoutWithAddBaseColN amount m = do m layoutBaseYPopInternal -layoutBaseYPushCur - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur = do traceLocal ("layoutBaseYPushCur") state <- mGet case _lstate_commentCol state of Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> layoutBaseYPushInternal (i + j) - (Left i , Nothing) -> layoutBaseYPushInternal i - (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state + (Left i, Just j) -> layoutBaseYPushInternal (i + j) + (Left i, Nothing) -> layoutBaseYPushInternal i + (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state Just cCol -> layoutBaseYPushInternal cCol -layoutBaseYPop - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPop :: (MonadMultiState LayoutState m) => m () layoutBaseYPop = do traceLocal ("layoutBaseYPop") layoutBaseYPopInternal -layoutIndentLevelPushCur - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur = do traceLocal ("layoutIndentLevelPushCur") state <- mGet - let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> i + j - (Left i , Nothing) -> i - (Right{}, Just j ) -> j - (Right{}, Nothing) -> 0 + let + y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> i + j + (Left i, Nothing) -> i + (Right{}, Just j) -> j + (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y -layoutIndentLevelPop - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") layoutIndentLevelPopInternal @@ -364,12 +329,12 @@ layoutIndentLevelPop = do -- make sense. layoutRemoveIndentLevelLinger -layoutAddSepSpace :: (MonadMultiState LayoutState m) - => m () +layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () layoutAddSepSpace = do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state + } -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. @@ -384,7 +349,7 @@ moveToExactAnn annKey = do traceLocal ("moveToExactAnn", annKey) anns <- mAsk case Map.lookup annKey anns of - Nothing -> return () + Nothing -> return () Just ann -> do -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann @@ -393,19 +358,19 @@ moveToExactAnn annKey = do moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY y = mModify $ \state -> - let upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then - _lstate_commentCol state - <|> _lstate_addSepSpace state - <|> Just (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } + let + upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in + state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just + (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do @@ -415,9 +380,7 @@ moveToY y = mModify $ \state -> -- else x ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m - => ExactPrint.DeltaPos - -> m () + :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ y $ mTell $ Text.Builder.fromString " " @@ -433,75 +396,77 @@ layoutWritePriorComments layoutWritePriorComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annPriorComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just priors -> do unless (null priors) $ layoutSetCommentCol - priors `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment + priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> + do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. -- per documentation, this seems sufficient, as the -- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Located ast -> m () +layoutWritePostComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Located ast + -> m () layoutWritePostComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just posts -> do unless (null posts) $ layoutSetCommentCol - posts `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment + posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> + do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment - :: ( MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - ) + :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) => m () layoutIndentRestorePostComment = do state <- mGet let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state - mModify $ \s -> s { _lstate_commentCol = Nothing - , _lstate_commentNewlines = 0 - } + let eCurYAddNL = _lstate_curYOrAddNewline state + mModify + $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) - _ -> return () + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe + 0 + (_lstate_addSepSpace state) + _ -> return () -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs index 08d0fd4..040320b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -27,151 +27,151 @@ import UI.Butcher.Monadic -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] } -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") - dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") - dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") - dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") - dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") - dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") - dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = mempty } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Bool.bool Nothing (Just True) @@ -218,8 +218,8 @@ readConfig path = do fileConf <- case Data.Yaml.decodeEither' contents of Left e -> do liftIO - $ putStrErrLn - $ "error reading in brittany config from " + $ putStrErrLn + $ "error reading in brittany config from " ++ path ++ ":" liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) @@ -233,11 +233,12 @@ readConfig path = do userConfigPath :: IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith Directory.doesFileExist - searchDirs - "config.yaml" + globalConfig <- Directory.findFileWith + Directory.doesFileExist + searchDirs + "config.yaml" maybe (writeUserConfig userBritPathXdg) pure globalConfig where writeUserConfig dir = do @@ -249,7 +250,7 @@ userConfigPath = do -- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir + let dirParts = FilePath.splitDirectories dir -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" @@ -261,8 +262,9 @@ readConfigs -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let merged = Semigroup.sconcat - $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + let + merged = + Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index bb7148d..0f0075a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -23,40 +23,40 @@ confUnpack :: Coercible a b => Identity a -> b confUnpack (Identity x) = coerce x data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. , _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentAmount :: f (Last Int) , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) + , _lconfig_importColumn :: f (Last Int) -- ^ for import statement layouting, column at which to align the -- elements to be imported from a module. -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) + , _lconfig_importAsColumn :: f (Last Int) -- ^ for import statement layouting, column at which put the module's -- "as" name (which also affects the positioning of the "as" keyword). -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) + , _lconfig_alignmentLimit :: f (Last Int) -- roughly speaking, this sets an upper bound to the number of spaces -- inserted to create horizontal alignment. -- More specifically, if 'xs' are the widths of the columns in some @@ -141,17 +141,17 @@ data CLayoutConfig f = LayoutConfig -- -- > , y :: Double -- -- > } } - deriving (Generic) + deriving Generic data CForwardOptions f = ForwardOptions { _options_ghc :: f [String] } - deriving (Generic) + deriving Generic data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) -- ^ Determines when to fall back on the exactprint'ed output when -- syntactical constructs are encountered which are not yet handled by -- brittany. @@ -161,21 +161,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig -- has different semantics than the code pre-transformation. , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CPreProcessorConfig f = PreProcessorConfig { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config @@ -186,10 +186,9 @@ data CConfig f = Config -- module. Useful for wildcard application -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) - + , _conf_obfuscate :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic type DebugConfig = CDebugConfig Identity type LayoutConfig = CLayoutConfig Identity diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 0c25537..c667038 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -29,7 +29,7 @@ import Language.Haskell.Brittany.Internal.Prelude aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany = Aeson.defaultOptions { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (=='_') + , Aeson.fieldLabelModifier = dropWhile (== '_') } instance FromJSON (CDebugConfig Maybe) where @@ -104,17 +104,27 @@ instance ToJSON (CConfig Maybe) where -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- config file content. instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = Config - <$> v .:? Key.fromString "conf_version" - <*> v .:?= Key.fromString "conf_debug" - <*> v .:?= Key.fromString "conf_layout" - <*> v .:?= Key.fromString "conf_errorHandling" - <*> v .:?= Key.fromString "conf_forward" - <*> v .:?= Key.fromString "conf_preprocessor" - <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" - <*> v .:? Key.fromString "conf_disable_formatting" - <*> v .:? Key.fromString "conf_obfuscate" - parseJSON invalid = Aeson.typeMismatch "Config" invalid + parseJSON (Object v) = + Config + <$> v + .:? Key.fromString "conf_version" + <*> v + .:?= Key.fromString "conf_debug" + <*> v + .:?= Key.fromString "conf_layout" + <*> v + .:?= Key.fromString "conf_errorHandling" + <*> v + .:?= Key.fromString "conf_forward" + <*> v + .:?= Key.fromString "conf_preprocessor" + <*> v + .:? Key.fromString "conf_roundtrip_exactprint_only" + <*> v + .:? Key.fromString "conf_disable_formatting" + <*> v + .:? Key.fromString "conf_obfuscate" + parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index b93fbbc..63d6b53 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -53,26 +53,30 @@ parseModuleFromString = ParseModule.parseModule commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob ast = do - let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` - (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) + let + extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` (\l@(L span _) -> + Seq.singleton (span, ExactPrint.mkAnnKey l) + ) let nodes = SYB.everything (<>) extract ast - let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] + let + annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (const id) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes + ] nodes `forM_` (snd .> processComs annsMap) where processComs annsMap annKey1 = do mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn `forM_` \ann1 -> do - let priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 + let + priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 let processCom :: (ExactPrint.Comment, ExactPrint.DeltaPos) @@ -84,31 +88,32 @@ commentAnnFixTransformGlob ast = do (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> move $> False (x, y) | x == y -> move $> False - _ -> return True + _ -> return True where ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 move = ExactPrint.modifyAnnsT $ \anns -> let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2' = ann2 { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] + ExactPrint.annFollowingComments ann2 ++ [comPair] } - in - Map.insert annKey2 ann2' anns + in Map.insert annKey2 ann2' anns _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors + priors' <- filterM processCom priors follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case + assocs' <- flip filterM assocs $ \case (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let ann1' = ann1 { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } + _ -> return True + let + ann1' = ann1 + { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns @@ -196,29 +201,30 @@ extractToplevelAnns lmod anns = output | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns ] declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + 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 +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 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 + (\x -> maybe Set.empty Set.singleton [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x + ] -- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- even though it is passed to mkAnnKey above, which only accepts -- SrcSpan. - ] ) ast where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) @@ -227,8 +233,8 @@ foldedAnnKeys ast = SYB.everything withTransformedAnns :: Data ast => ast - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case readers@(conf :+: anns :+: HNil) -> do -- TODO: implement `local` for MultiReader/MultiRWS @@ -238,9 +244,10 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case pure x where f anns = - let ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced + let + ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced warnExtractorCompat :: GHC.Warn -> String diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 4606eac..136468e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -56,7 +56,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString str + _ -> mTell $ Text.Builder.fromString str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -68,9 +68,10 @@ briDocByExact -> ToBriDocM BriDocNumbered briDocByExact ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns True -- | Use ExactPrint's output for this node. @@ -84,9 +85,10 @@ briDocByExactNoComment -> ToBriDocM BriDocNumbered briDocByExactNoComment ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns False -- | Use ExactPrint's output for this node, presuming that this output does @@ -99,24 +101,26 @@ briDocByExactInlineOnly -> ToBriDocM BriDocNumbered briDocByExactInlineOnly infoStr ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t - let errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit - $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + let + exactPrintNode t = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + t + let + errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _ ) -> errorAction - (_ , [t]) -> exactPrintNode + (ExactPrintFallbackModeNever, _) -> errorAction + (_, [t]) -> exactPrintNode (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted _ -> errorAction @@ -141,20 +145,21 @@ lrdrNameToTextAnnGen lrdrNameToTextAnnGen f ast@(L _ n) = do anns <- mAsk let t = f $ rdrNameToText n - let hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False + let + hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. -- whatever we don't probably should have had some effect on the -- output. in such cases, resorting to byExact is probably the safe -- choice. return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t + Nothing -> t Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t lrdrNameToTextAnn :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) @@ -167,9 +172,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial => Located RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + let + f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x lrdrNameToTextAnnGen f ast -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects @@ -187,10 +193,11 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick -> m Text lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + x <- lrdrNameToTextAnn ast2 + let + lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x return $ if hasQuote then Text.cons '\'' lit else lit askIndent :: (MonadMultiReader Config m) => m Int @@ -208,12 +215,11 @@ extractRestComments ann = ExactPrint.annFollowingComments ann ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] + _ -> [] ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) -- | True if there are any comments that are -- a) connected to any node below (in AST sense) the given node AND @@ -231,15 +237,16 @@ hasCommentsBetween -> ToBriDocM Bool hasCommentsBetween ast leftKey rightKey = do mAnn <- astAnn ast - let go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest + let + go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest case mAnn of - Nothing -> pure False + Nothing -> pure False Just ann -> pure $ go1 $ ExactPrint.annsDP ann -- | True if there are any comments that are connected to any node below (in AST @@ -286,7 +293,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False + Nothing -> False Just ann -> any hasK (extractAllComments ann) where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst @@ -300,7 +307,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks where hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False + hasK _ = False astAnn :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) @@ -449,16 +456,13 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) deriving (Functor, Applicative, Monad) addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = - when cond (addAlternative doc) +addAlternativeCond cond doc = when cond (addAlternative doc) addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = - CollectAltM . Writer.tell . (: []) +addAlternative = CollectAltM . Writer.tell . (: []) runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered -runFilteredAlternative (CollectAltM action) = - docAlt $ Writer.execWriter action +runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered @@ -506,7 +510,8 @@ docAnnotationKW -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm +docAnnotationKW annKey kw bdm = + allocateNode . BDFAnnotationKW annKey kw =<< bdm docMoveToKWDP :: AnnKey @@ -558,7 +563,7 @@ docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] docParenHashRSep :: ToBriDocM BriDocNumbered docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] @@ -620,32 +625,26 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNodePrior ast bdm = do bd <- bdm i1 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ bd + return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd docWrapNodeRest ast bdm = do bd <- bdm i2 <- allocNodeIndex - return - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd + return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where docWrapNode ast bdms = case bdms of [] -> [] [bd] -> [docWrapNode ast bd] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdms = case bdms of [] -> [] [bd] -> [docWrapNodePrior ast bd] - (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR + (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + [] -> [] + (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do @@ -655,25 +654,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ [bd1'] ++ reverse bdM ++ [bdN'] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdsm = do bds <- bdsm case bds of [] -> return [] - (bd1:bdR) -> do + (bd1 : bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return (bd1':bdR) + return (bd1' : bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of [] -> return [] - (bdN:bdR) -> do + (bdN : bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN':bdR) + return $ reverse (bdN' : bdR) instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do @@ -686,7 +685,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where return $ Seq.singleton bd1' bdM Seq.:> bdN -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ (bd1' Seq.<| bdM) Seq.|> bdN' docWrapNodePrior ast bdsm = do bds <- bdsm @@ -730,7 +729,7 @@ docPar -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docPar lineM indentedM = do - line <- lineM + line <- lineM indented <- indentedM allocateNode $ BDFPar BrIndentNone line indented @@ -767,14 +766,15 @@ briDocMToPPM m = do briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR - let ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m + let + ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index dc7d022..37f648e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -27,28 +27,29 @@ layoutDataDecl -> ToBriDocM BriDocNumbered layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> - docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) + -> docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl -- data MyData a b @@ -56,8 +57,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "data" , lhsContextDoc @@ -69,24 +70,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- data MyData = MyData { .. } HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> - docWrapNode ltycl $ do + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) + -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing + Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- return <$> createDetailsDoc consNameStr details - consDoc <- fmap pure + rhsDoc <- return <$> createDetailsDoc consNameStr details + consDoc <- + fmap pure $ docNonBottomSpacing $ case (forallDocMay, rhsContextDocMay) of (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [ docLitS "." , docSeparator @@ -94,7 +97,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of ] ] (Just forallDoc, Nothing) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [docLitS ".", docSeparator, rhsDoc] ] (Nothing, Just rhsContextDoc) -> docSeq @@ -102,12 +106,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSeparator , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] - (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] + (Nothing, Nothing) -> + docSeq [docLitS "=", docSeparator, rhsDoc] createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline $ lhsContextDoc , appSep $ docLit nameStr @@ -119,12 +123,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -132,26 +137,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr , tyVarLine ] ) - ( docSeq + (docSeq [ docLitS "=" , docSeparator , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -162,8 +167,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -184,13 +188,10 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- hurt. docAddBaseY BrIndentRegular $ docPar (docLitS "data") - ( docLines + (docLines [ lhsContextDoc , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLit nameStr - , tyVarLine - ] + $ docSeq [appSep $ docLit nameStr, tyVarLine] , consDoc ] ) @@ -204,20 +205,20 @@ createContextDoc [] = docEmpty createContextDoc [t] = docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 + t1Doc <- docSharedWrapper layoutType t1 tRDocs <- tR `forM` docSharedWrapper layoutType docAlt [ docSeq [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse docCommaSep - (t1Doc : tRDocs) + , docForceSingleline $ docSeq $ List.intersperse + docCommaSep + (t1Doc : tRDocs) , docLitS ") =>" , docSeparator ] , docLines $ join [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs - <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] , [docLitS ") =>", docSeparator] ] ] @@ -229,20 +230,18 @@ createBndrDoc bs = do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) - docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] + docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> + case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -251,10 +250,10 @@ createDerivingPar derivs mainDoc = do (L _ []) -> mainDoc (L _ types) -> docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered @@ -263,36 +262,33 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of (L _ ts) -> let tsLength = length ts - whenMoreThan1Type val = - if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in - docSeq - [ docDeriving - , docWrapNodePrior types $ lhsStrategy - , docSeparator - , whenMoreThan1Type "(" - , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts <&> \case + whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = + maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in docSeq + [ docDeriving + , docWrapNodePrior types $ lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docWrapNodeRest types + $ docSeq + $ List.intersperse docCommaSep + $ ts + <&> \case HsIB _ t -> layoutType t - , whenMoreThan1Type ")" - , rhsStrategy - ] + , whenMoreThan1Type ")" + , rhsStrategy + ] where strategyLeftRight = \case - (L _ StockStrategy ) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes) ) -> + (L _ StockStrategy) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) + lVia@(L _ (ViaStrategy viaTypes)) -> ( docEmpty , case viaTypes of - HsIB _ext t -> docSeq - [ docWrapNode lVia $ docLitS " via" - , docSeparator - , layoutType t - ] + HsIB _ext t -> + docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] ) docDeriving :: ToBriDocM BriDocNumbered @@ -302,21 +298,24 @@ createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq [ docLit consNameStr , docSeparator , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ fmap hsScaledThing args <&> layoutType + $ docSeq + $ List.intersperse docSeparator + $ fmap hsScaledThing args + <&> layoutType ] - leftIndented = docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType <$> fmap hsScaledThing args + leftIndented = + docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType + <$> fmap hsScaledThing args multiAppended = docSeq [ docLit consNameStr , docSeparator @@ -326,79 +325,80 @@ createDetailsDoc consNameStr details = case details of (docLit consNameStr) (docLines $ layoutType <$> fmap hsScaledThing args) case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyFree -> docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_:_)) -> do + RecCon (L _ []) -> + docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_ : _)) -> do let ((fName1, fType1) : fDocR) = mkFieldDocs fields -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False - docAddBaseY BrIndentRegular - $ runFilteredAlternative - $ do + docAddBaseY BrIndentRegular $ runFilteredAlternative $ do -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols + ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols + ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 + , docForceSingleline fType ] , docSeq - [ docLitS "{" + [ docLitS "," , docSeparator , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) + fName + (docSeq [docLitS "::", docSeparator, fType]) ] ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType - ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] - , docLitS "}" - ] - ) + , docLitS "}" + ] + ) InfixCon arg1 arg2 -> docSeq [ layoutType $ hsScaledThing arg1 , docSeparator @@ -413,10 +413,11 @@ createDetailsDoc consNameStr details = case details of mkFieldDocs = fmap $ \lField -> case lField of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t -createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = Just $ docSeq - [docLitS "forall ", createBndrDoc lhsTyVarBndrs] +createForallDoc + :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = + Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc :: Data.Data.Data ast @@ -426,12 +427,8 @@ createNamesAndTypeDoc -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \case - L _ (FieldOcc _ fieldName) -> - docLit =<< lrdrNameToTextAnn fieldName + [ docSeq $ List.intersperse docCommaSep $ names <&> \case + L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName ] , docWrapNodeRest lField $ layoutType t ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index db58abc..9e22b6e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -42,11 +42,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint layoutDecl :: ToBriDoc HsDecl layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> @@ -64,47 +64,54 @@ layoutSig lsig@(L _loc sig) = case sig of docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " + let + phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let + conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ + PatSynSig _ names (HsIB _ typ) -> + layoutNamesAndType (Just "pattern") names typ _ -> briDocByExactNoComment lsig -- TODO where layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] + let + keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- mAsk - <&> _conf_layout - .> _lconfig_hangingTypeSignature - .> confUnpack + shouldBeHanging <- + mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging - then docSeq $ - [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc + then + docSeq + $ [ appSep + $ docWrapNodeRest lsig + $ docSeq + $ keyDoc + <> [docLit nameStr] + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ] ] - ] - ] else layoutLhsAndType hasComments (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) @@ -114,22 +121,23 @@ layoutSig lsig@(L _loc sig) = case sig of specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body + BodyStmt _ body _ _ -> layoutExpr body BindStmt _ lPat expr -> do patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr - docCols ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO + docCols + ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- @@ -137,37 +145,33 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -------------------------------------------------------------------------------- layoutBind - :: ToBriDocC - (HsBindLR GhcPs GhcPs) - (Either [BriDocNumbered] BriDocNumbered) + :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" funcPatDocs <- docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches return $ Left $ funcPatDocs PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat + patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" + binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal + Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereArg + hasComments PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID - lpat - dir - rpat + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of @@ -177,7 +181,13 @@ layoutIPBind lipbind@(L _ bind) = case bind of binderDoc <- docLit $ Text.pack "=" exprDoc <- layoutExpr expr hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments + layoutPatternBindFinal + Nothing + binderDoc + (Just ipName) + [([], exprDoc, expr)] + Nothing + hasComments data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) @@ -185,7 +195,7 @@ data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) @@ -195,18 +205,18 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + let + unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s + BagSig s -> return <$> layoutSig s return $ Just $ docs -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> - Just <$> mapM layoutIPBind bb + HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is @@ -216,7 +226,7 @@ layoutGrhs -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body + bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) layoutPatternBind @@ -225,7 +235,7 @@ layoutPatternBind -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match + let pats = m_pats match let (GRHSs _ grhss whereBinds) = m_grhss match patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match @@ -234,25 +244,26 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1:p2:pr) | isInfix -> if null pr - then - docCols ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else - docCols ColPatternsFuncInfix - ( [docCols ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR - ] + (Just idStr, p1 : p2 : pr) | isInfix -> if null pr + then docCols + ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else docCols + ColPatternsFuncInfix + ([ docCols + ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) + ] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix @@ -266,30 +277,30 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments + layoutPatternBindFinal + alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereArg + hasComments -fixPatternBindIdentifier - :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match where go = \case - (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr + (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1 ) -> goInner ctx1 - _ -> idStr + (StmtCtxt ctx1) -> goInner ctx1 + _ -> idStr -- I have really no idea if this path ever occurs, but better safe than -- risking another "drop bangpatterns" bugs. goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr + _ -> idStr layoutPatternBindFinal :: Maybe Text @@ -300,304 +311,302 @@ layoutPatternBindFinal -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do - let patPartInline = case mPatDoc of - Nothing -> [] +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments + = do + let + patPartInline = case mPatDoc of + Nothing -> [] Just patDoc -> [appSep $ docForceSingleline $ return patDoc] patPartParWrap = case mPatDoc of - Nothing -> id + Nothing -> id Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- mAsk - <&> _conf_layout - .> _lconfig_indentWhereSpecial - .> confUnpack - regularIndentAmount <- mAsk - <&> _conf_layout - .> _lconfig_indentAmount - .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt - [ docEnsureIndent BrIndentRegular - $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False + whereIndent <- do + shouldSpecial <- + mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack + regularIndentAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + [ docEnsureIndent BrIndentRegular + $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docMoveToKWDP annKeyWhere AnnWhere False $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty + ] + ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let + singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse docCommaSep - (docForceSingleline . return <$> gs) + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + gs -> + docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ (List.intersperse + docCommaSep + (docForceSingleline . return <$> gs) ) wherePart = case mWhereDocs of - Nothing -> Just docEmpty + Nothing -> Just docEmpty Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] - _ -> Nothing + _ -> Nothing - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - runFilteredAlternative $ do + runFilteredAlternative $ do - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' + ] ] - ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1:gr) -> - ( docSeq [appSep $ docLit $ Text.pack "|", return g1] - : ( gr - <&> \g -> - docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline $ docSeq + [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] - ] - ] - ++ wherePartMultiLine + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1 : gr) -> + (docSeq [appSep $ docLit $ Text.pack "|", return g1] + : (gr <&> \g -> + docSeq [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine -- | Layout a pattern synonym binding layoutPatSynBind @@ -607,44 +616,50 @@ layoutPatSynBind -> LPat GhcPs -> ToBriDocM BriDocNumbered layoutPatSynBind name patSynDetails patDir rpat = do - let patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" + let + patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir - headDoc <- fmap pure $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] + headDoc <- + fmap pure + $ docSeq + $ [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] runFilteredAlternative $ do - addAlternative $ + addAlternative + $ -- pattern .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docSeq - ( [headDoc, docSeparator, body] - ++ case mWhereDocs of + docAddBaseY BrIndentRegular + $ docSeq + ([headDoc, docSeparator, body] ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] - ) - addAlternative $ + ) + addAlternative + $ -- pattern .. = -- .. -- pattern .. <- -- .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) - ) + docAddBaseY BrIndentRegular + $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) + ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn @@ -663,18 +678,21 @@ layoutLPatSyn name (InfixCon left right) = do layoutLPatSyn name (RecCon recArgs) = do docName <- lrdrNameToTextAnn name args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq . fmap docLit - $ [docName, Text.pack " { " ] + docSeq + . fmap docLit + $ [docName, Text.pack " { "] <> intersperse (Text.pack ", ") args <> [Text.pack " }"] -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms -layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere + :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG _ (L _ lbinds) _) -> do binderDoc <- docLit $ Text.pack "=" - Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + Just + <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing -------------------------------------------------------------------------------- @@ -684,9 +702,10 @@ layoutPatSynWhere hs = case hs of layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl _ name vars fixity typ -> do - let isInfix = case fixity of - Prefix -> False - Infix -> True + let + isInfix = case fixity of + Prefix -> False + Infix -> True -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl @@ -715,9 +734,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do -- This isn't quite right, but does give syntactically valid results let needsParens = not (null rest) || hasOwnParens docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - ] + $ [docLit $ Text.pack "type", docSeparator] ++ [ docParenL | needsParens ] ++ [ layoutTyVarBndr False a , docSeparator @@ -729,13 +746,13 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do ++ fmap (layoutTyVarBndr True) rest else docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc @@ -744,11 +761,11 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name - docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] + docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] KindedTyVar _ _ name kind -> do nameStr <- lrdrNameToTextAnn name docSeq - $ [ docSeparator | needsSep ] + $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" @@ -776,7 +793,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name + nameStr <- lrdrNameToTextAnn name needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass @@ -787,33 +804,34 @@ layoutTyFamInstDecl inClass outerNode tfid = do makeForallDoc bndrs = do bndrDocs <- layoutTyVarBndrs bndrs docSeq - ( [docLit (Text.pack "forall")] - ++ processTyVarBndrsSingleline bndrDocs + ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs ) lhs = docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] + . docSeq + $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] - hasComments <- (||) + hasComments <- + (||) <$> hasAnyRegularCommentsConnected outerNode <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc -layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats + :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm + HsValArg tm -> layoutType tm HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change -- is a bit strange. Hopefully this does not ignore any important -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" + HsArgPar _l -> error "brittany internal error: HsArgPar{}" -------------------------------------------------------------------------------- -- ClsInstDecl @@ -828,27 +846,27 @@ layoutClsInst :: ToBriDoc ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) ] where layoutInstanceHead :: ToBriDocM BriDocNumbered layoutInstanceHead = briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren <$> lcid removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] , cid_datafam_insts = [] } @@ -856,7 +874,11 @@ layoutClsInst lcid@(L _ cid) = docLines docSortedLines :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = - allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l + allocateNode + . BDFLines + . fmap unLoc + . List.sortOn (ExactPrint.rs . getLoc) + =<< sequence l layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig @@ -868,8 +890,8 @@ layoutClsInst lcid@(L _ cid) = docLines joinBinds :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n + Left ns -> docLines $ return <$> ns + Right n -> return n layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) @@ -935,10 +957,11 @@ layoutClsInst lcid@(L _ cid) = docLines stripWhitespace' t = Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t where - go [] = [] + go [] = [] go (line1 : lineR) = case Text.stripStart line1 of - st | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR + st + | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "newtype" `Text.isPrefixOf` t') diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 9a13adf..138a748 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -29,119 +29,127 @@ import Language.Haskell.Brittany.Internal.Utils layoutExpr :: ToBriDoc HsExpr layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of HsVar _ vname -> do docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> - docLit $ Text.pack $ occNameString oname + HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '#' : label + let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '?' : label + let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label HsOverLit _ olit -> do allocateNode $ overLitValBriDoc $ ol_val olit HsLit _ lit -> do allocateNode $ litBriDoc lit HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds {} <- llocals - , L _ (GRHS _ [] body) <- lgrhs + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds{} <- llocals + , L _ (GRHS _ [] body) <- lgrhs -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let shouldPrefixSeparator = case p of + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let + shouldPrefixSeparator = case p of L _ LazyPat{} -> isFirst L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let funcPatternPartLine = - docCols ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- + docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let + funcPatternPartLine = docCols + ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing - $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing $ docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> - unknownNodeError "HsLam too complex" lexpr + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> unknownNodeError "HsLam too complex" lexpr HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing $ docAddBaseY BrIndentRegular $ - (docLit $ Text.pack "\\case {}") + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ (docLit $ Text.pack "\\case {}") HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r:list) l - x -> (x, list) + let + gather + :: [LHsExpr GhcPs] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [LHsExpr GhcPs]) + gather list = \case + L _ (HsApp _ l r) -> gather (r : list) l + x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 - let colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq + let + colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs hasComments <- hasAnyCommentsConnected exp2 @@ -153,45 +161,37 @@ layoutExpr lexpr@(L _ expr) = do : spacifyDocs (docForceSingleline <$> paramDocs) -- foo x -- y - addAlternativeCond allowFreeIndent - $ docSeq + addAlternativeCond allowFreeIndent $ docSeq [ appSep (docForceSingleline headDoc) , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ docForceSingleline <$> paramDocs + $ docForceSingleline + <$> paramDocs ] -- foo -- x -- y - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline headDoc) - ( docNonBottomSpacing - $ docLines paramDocs - ) + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docForceSingleline headDoc) + (docNonBottomSpacing $ docLines paramDocs) -- ( multi -- line -- function -- ) -- x -- y - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - headDoc - ( docNonBottomSpacing - $ docLines paramDocs - ) + addAlternative $ docAddBaseY BrIndentRegular $ docPar + headDoc + (docNonBottomSpacing $ docLines paramDocs) HsApp _ exp1 exp2 -> do -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 docAlt [ -- func arg - docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + docSeq + [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] , -- func argline1 -- arglines -- e.g. @@ -204,77 +204,70 @@ layoutExpr lexpr@(L _ expr) = do -- anyways, so it is _always_ par-spaced. $ docAddBaseY BrIndentRegular $ docSeq - [ appSep $ docForceSingleline expDoc1 - , docForceParSpacing expDoc2 - ] + [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] , -- func -- arg - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docForceSingleline expDoc1) (docNonBottomSpacing expDoc2) , -- fu -- nc -- ar -- gument - docAddBaseY BrIndentRegular - $ docPar - expDoc1 - expDoc2 + docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 ] HsAppType _ exp1 (HsWC _ ty1) -> do t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 docAlt [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar - e - (docSeq [docLit $ Text.pack "@", t ]) + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar e (docSeq [docLit $ Text.pack "@", t]) ] OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft + let + gather + :: [(LHsExpr GhcPs, LHsExpr GhcPs)] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) + gather opExprList = \case + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight + appListDocs <- appList `forM` \(x, y) -> + [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight allowSinglelinePar <- do hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp + hasComOp <- hasAnyCommentsConnected expOp pure $ not hasComLeft && not hasComOp - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True runFilteredAlternative $ do -- > one + two + three -- or -- > one + two + case x of -- > _ -> three - addAlternativeCond allowSinglelinePar - $ docSeq + addAlternativeCond allowSinglelinePar $ docSeq [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] + , docSeq $ appListDocs <&> \(od, ed) -> docSeq + [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] , appSep $ docForceSingleline opLastDoc , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc + expLastDoc ] -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) @@ -289,29 +282,31 @@ layoutExpr lexpr@(L _ expr) = do -- > one -- > + two -- > + three - addAlternative $ - docPar - leftOperandDoc - ( docLines - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + addAlternative $ docPar + leftOperandDoc + (docLines + $ (appListDocs <&> \(od, ed) -> + docCols ColOpPrefix [appSep od, docSetBaseY ed] ) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let + leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line - addAlternative - $ docSeq + addAlternative $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceSingleline expDocRight @@ -326,35 +321,35 @@ layoutExpr lexpr@(L _ expr) = do -- two-line addAlternative $ do let - expDocOpAndRight = docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + expDocOpAndRight = docForceSingleline $ docCols + ColOpPrefix + [appSep $ expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight -- TODO: in both cases, we don't force expDocLeft to be -- single-line, which has certain.. interesting consequences. -- At least, the "two-line" label is not entirely -- accurate. -- one-line + par - addAlternativeCond allowPar - $ docSeq + addAlternativeCond allowPar $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceParSpacing expDocRight ] -- more lines addAlternative $ do - let expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + let + expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight + $ docPar expDocLeft expDocOpAndRight NegApp _ op _ -> do opDoc <- docSharedWrapper layoutExpr op - docSeq [ docLit $ Text.pack "-" - , opDoc - ] + docSeq [docLit $ Text.pack "-", opDoc] HsPar _ innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -364,7 +359,8 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack ")" ] , docSetBaseY $ docLines - [ docCols ColOpPrefix + [ docCols + ColOpPrefix [ docLit $ Text.pack "(" , docAddBaseY (BrIndentSpecial 2) innerExpDoc ] @@ -373,33 +369,34 @@ layoutExpr lexpr@(L _ expr) = do ] SectionL _ left op -> do -- TODO: add to testsuite leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple _ args boxity -> do - let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e); - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs - $ docSharedWrapper - $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- orM - ( hasCommentsBetween lexpr AnnOpenP AnnCloseP - : map hasAnyCommentsBelow args - ) - let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) + let + argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e) + (L _ (Missing NoExtField)) -> (arg, Nothing) + argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> + docWrapNode arg $ maybe docEmpty layoutExpr exprM + hasComments <- + orM + (hasCommentsBetween lexpr AnnOpenP AnnCloseP + : map hasAnyCommentsBelow args + ) + let + (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) case splitFirstLast argDocs of - FirstLastEmpty -> docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) closeLit - ] + FirstLastEmpty -> + docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] FirstLastSingleton e -> docAlt - [ docCols ColTuple + [ docCols + ColTuple [ openLit , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e , closeLit @@ -414,74 +411,88 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] - addAlternative $ - let - start = docCols ColTuples - [appSep openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + ++ [ docSeq + [ docCommaSep + , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) + , closeLit + ] + ] + addAlternative + $ let + start = docCols ColTuples [appSep openLit, e1] + linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] + lineN = docCols + ColTuples + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase _ cExp (MG _ (L _ []) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp docAlt - [ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] + [ docAddBaseY BrIndentRegular $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") ] HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches docAlt - [ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq + [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq [ appSep $ docLit $ Text.pack "case" , appSep $ docForceSingleline cExpDoc , docLit $ Text.pack "of" - ]) - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + ] + ) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "of") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "of") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs ) + ) ] HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr + ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr hasComments <- hasAnyCommentsBelow lexpr - let maySpecialIndent = - case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 + let + maySpecialIndent = case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. docSetIndentLevel $ runFilteredAlternative $ do -- if _ then _ else _ - addAlternativeCond (not hasComments) - $ docSeq + addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc , appSep $ docLit $ Text.pack "then" @@ -502,29 +513,34 @@ layoutExpr lexpr@(L _ expr) = do -- else -- stuff -- note that this has par-spacing - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docNonBottomSpacing + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc ] , docAddBaseY BrIndentRegular - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ] + ) -- either -- if multi -- line @@ -542,62 +558,69 @@ layoutExpr lexpr@(L _ expr) = do -- else -- stuff -- note that this does _not_ have par-spacing - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc ] , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - addAlternative - $ docSetBaseY - $ docLines - [ docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc ] + ) + addAlternative $ docSetBaseY $ docLines + [ docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" hasComments <- hasAnyCommentsBelow lexpr docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") - (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) + (layoutPatternBindFinal + Nothing + binderDoc + Nothing + clauseDocs + Nothing + hasComments + ) HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = - case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x + ifIndentFreeElse x y = case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), -- but is here due to ghc-exactprint's DP handling of "let" in @@ -610,36 +633,35 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) - $ appSep $ docForceSingleline bindDoc + , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline + bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ] addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) + [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc ] + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) + ] , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY expDoc1) + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse + docSetBaseAndIndent + docForceSingleline + expDoc1 ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) + ] ] - Just bindDocs@(_:_) -> runFilteredAlternative $ do + Just bindDocs@(_ : _) -> runFilteredAlternative $ do --either -- let -- a = b @@ -653,102 +675,91 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - let noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular - $ docForceParSpacing expDoc1 - ] + let + noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 ] + ] addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docSeq + IndentPolicyFree -> docLines + [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines bindDocs ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY expDoc1 - ] + , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] ] - addAlternative - $ docLines + addAlternative $ docLines [ docNodeAnnKW lexpr (Just AnnLet) $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of DoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) MDoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ docForceSingleline <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative $ - let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x + | case x of + ListComp -> True + MonadComp -> True + _ -> False + -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq + $ List.intersperse docCommaSep + $ docForceSingleline + <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative + $ let + start = docCols + ColListComp + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack + "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1 : sM) = List.init stmtDocs + line1 = + docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] _ -> do -- TODO unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr + ExplicitList _ _ elems@(_ : _) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of FirstLastEmpty -> docSeq @@ -772,109 +783,106 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse + docCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) + ) ++ [docLit $ Text.pack "]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> - docLit $ Text.pack "[]" - RecordCon _ lname fields -> - case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- fs - `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> docCols ColList [docCommaSep, d] + lineN = docCols + ColList + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ExplicitList _ _ [] -> docLit $ Text.pack "[]" + RecordCon _ lname fields -> case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- + fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression False indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just (L _ 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- + fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr + recordExpression True indentPolicy lexpr nameDoc fieldDocs + _ -> unknownNodeError "RecordCon with puns" lexpr RecordUpd _ rExpr fields -> do rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- fields - `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFs <- + fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do rFExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ case ambName of Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) recordExpression False indentPolicy lexpr rExprDoc rFs ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 - docSeq - [ appSep expDoc - , appSep $ docLit $ Text.pack "::" - , typDoc - ] - ArithSeq _ Nothing info -> - case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> - briDocByExactInlineOnly "ArithSeq" lexpr + docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] + ArithSeq _ Nothing info -> case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr HsBracket{} -> do -- TODO briDocByExactInlineOnly "HsBracket{}" lexpr @@ -887,11 +895,12 @@ layoutExpr lexpr@(L _ expr) = do HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do allocateNode $ BDFPlain (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]") + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]" + ) HsSpliceE{} -> do -- TODO briDocByExactInlineOnly "HsSpliceE{}" lexpr @@ -923,78 +932,79 @@ recordExpression -> IndentPolicy -> GenLocated SrcSpan lExpr -> ToBriDocM BriDocNumbered - -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] + -> [ ( GenLocated SrcSpan name + , Text + , Maybe (ToBriDocM BriDocNumbered) + ) + ] -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = - docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = - docSeq -- this case might still be incomplete, and is probably not used +recordExpression False _ lexpr nameDoc [] = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do let (rF1f, rF1n, rF1e) = rF1 runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } - addAlternative - $ docSeq + addAlternative $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr + , docSeq $ List.intersperse docCommaSep $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr , if dotdot - then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator + then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator , docLit $ Text.pack "}" ] -- hanging single-line fields -- container { fieldA = blub -- , fieldB = blub -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docSeq + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRec + , docSetBaseY + $ docLines + $ let + line1 = docCols + ColRec [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit rF1n , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty + Just x -> docWrapNodeRest rF1f $ docSeq + [appSep $ docLit $ Text.pack "=", docForceSingleline x] + Nothing -> docEmpty ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> + docSeq [appSep $ docLit $ Text.pack "=", docForceSingleline x] Nothing -> docEmpty - ] + ] dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] + in [line1] ++ lineR ++ [dotdotLine, lineN] ] -- non-hanging with expressions placed to the right of the names -- container @@ -1002,77 +1012,75 @@ recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do -- , fieldB = potentially -- multiline -- } - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield - $ docCols ColRec + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing + $ docLines + $ let + line1 = docCols + ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec [ docCommaSep , appSep $ docLit fText , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq [ appSep $ docLit $ Text.pack "=" - , docForceParSpacing x - ] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty ] - dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) + dotdotLine = if dotdot + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ) litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t _ -> error "litBriDoc: literal with no SourceText" overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 78c56e4..8684842 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -35,36 +35,40 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] IEThingWith _ x _ ns _ -> do hasComments <- orM - ( hasCommentsBetween lie AnnOpenP AnnCloseP + (hasCommentsBetween lie AnnOpenP AnnCloseP : hasAnyCommentsBelow x : map hasAnyCommentsBelow ns ) let sortedNs = List.sortOn wrappedNameToText ns runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] + $ docSeq + $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc sortedNs) ++ [docParenR] addAlternative $ docWrapNodeRest lie $ docAddBaseY BrIndentRegular - $ docPar - (layoutWrapped lie x) - (layoutItems (splitFirstLast sortedNs)) + $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) where nameDoc = docLit <=< lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] + , docParenR + ] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] + , docParenR + ] layoutItems (FirstLast n1 nMs nN) = docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs - ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] + ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] + , docParenR + ] IEModuleContents _ n -> docSeq [ docLit $ Text.pack "module" , docSeparator @@ -73,7 +77,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEPattern n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "pattern " <> name @@ -90,33 +94,36 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] + :: SortItemsFlag + -> Located [LIE GhcPs] + -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] - let sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText - $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies + let + sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let + ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] + FirstLastEmpty -> [] FirstLastSingleton ie -> [ie] FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] pure $ fmap pure ieCommaDocs -- returned shared nodes where mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] + mergeGroup [] = [] mergeGroup items@[_] = items - mergeGroup items = if + mergeGroup items = if | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items -- proper means that if it is a ThingWith, it does not contain a wildcard -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). @@ -129,21 +136,22 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True - _ -> False + _ -> False thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{} ) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 ( L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder l1@(L _ IEVar{}) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 (L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l - (IEThingWith x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) + (IEThingWith + x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) ) thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -162,9 +170,10 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs + :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies + ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies runFilteredAlternative $ case ieDs of [] -> do @@ -174,14 +183,14 @@ layoutLLIEs enableSingleline shouldSort llies = do docParenR (ieDsH : ieDsT) -> do addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] + $ docSeq + $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) ++ [docParenR] addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT ++ [docParenR] -- | Returns a "fingerprint string", not a full text representation, nor even @@ -189,26 +198,27 @@ layoutLLIEs enableSingleline shouldSort llies = do -- Used for sorting, not for printing the formatter's output source code. wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n + L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. lieToText :: LIE GhcPs -> Text lieToText = \case - L _ (IEVar _ wn ) -> wrappedNameToText wn - L _ (IEThingAbs _ wn ) -> wrappedNameToText wn - L _ (IEThingAll _ wn ) -> wrappedNameToText wn + L _ (IEVar _ wn) -> wrappedNameToText wn + L _ (IEThingAbs _ wn) -> wrappedNameToText wn + L _ (IEThingAll _ wn) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn -- TODO: These _may_ appear in exports! -- Need to check, and either put them at the top (for module) or do some -- other clever thing. L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" where moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) + moduleNameToText (L _ name) = + Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index d8ff3ff..fc17cde 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -30,111 +30,128 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered layoutImport importD = case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + importAsCol <- + mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let - compact = indentPolicy /= IndentPolicyFree + compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = - let qualifiedPart = if q /= NotQualified then length "qualified " else 0 - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal + let + qualifiedPart = if q /= NotQualified then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = case src of + IsBoot -> length "{-# SOURCE #-} " + NotBoot -> 0 + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength + asCost = length "as " + hidingParenCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" - , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } + , case src of + IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}" + NotBoot -> docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty - , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty + , if q /= NotQualified + then appSep $ docLit $ Text.pack "qualified" + else docEmpty , maybe docEmpty (appSep . docLit) pkgNameT ] indentName = if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = - indentName $ appSep $ docLit modNameT + modNameD = indentName $ appSep $ docLit modNameT hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = if hiding - then appSep $ docLit $ Text.pack "hiding" - else docEmpty + hidDoc = + if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of + bindingsD = case mllies of Nothing -> docEmpty Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docAlt - [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] - , let makeParIfHiding = if hiding + then docAlt + [ docSeq + [ hidDoc + , docForceSingleline $ layoutLLIEs True ShouldSortItems llies + ] + , let + makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar - (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - ( docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + ] + else do + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq + [hidDoc, docParenLSep, docWrapNode llies docEmpty] + ) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + else docSeq + [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + -- ..[hiding].( b + -- , b' + -- ) + (ieD : ieDs') -> docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] + ) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular $ - docPar (docSeq [importHead, asDoc]) bindingsD - ] - else - case masT of + then + let asDoc = maybe docEmpty makeAsDoc masT + in + docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular + $ docPar (docSeq [importHead, asDoc]) bindingsD + ] + else case masT of Just n -> if enoughRoom - then docLines - [ docSeq [importHead, asDoc], bindingsD] + then docLines [docSeq [importHead, asDoc], bindingsD] else docLines [importHead, asDoc, bindingsD] where enoughRoom = nameCost < importAsCol - asCost - asDoc = - docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n + asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) + $ makeAsDoc n Nothing -> if enoughRoom then docSeq [importHead, bindingsD] else docLines [importHead, bindingsD] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 73090ce..8de45d7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -25,7 +25,7 @@ import Language.Haskell.GHC.ExactPrint.Types layoutModule :: ToBriDoc' HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do + HsModule _ Nothing _ imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) @@ -36,10 +36,8 @@ layoutModule lmod@(L _ mod') = case mod' of -- groupify commentedImports `forM_` tellDebugMessShow -- sortedImports <- sortImports imports let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- mAsk - <&> _conf_layout - .> _lconfig_allowSingleLineExportList - .> confUnpack + allowSingleLineExportList <- + mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack -- the config should not prevent single-line layout when there is no -- export list let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les @@ -49,30 +47,26 @@ layoutModule lmod@(L _ mod') = case mod' of -- A pseudo node that serves merely to force documentation -- before the node , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ - docForceSingleline - $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative - $ docLines + addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + addAlternative $ docLines [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docSeq [ - docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) + (docSeq + [ docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + ) ] ] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] @@ -84,7 +78,7 @@ data CommentedImport instance Show CommentedImport where show = \case - EmptyLine -> "EmptyLine" + EmptyLine -> "EmptyLine" IndependentComment _ -> "IndependentComment" ImportStatement r -> "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show @@ -97,8 +91,9 @@ data ImportStatementRecord = ImportStatementRecord } instance Show ImportStatementRecord where - show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) + show r = + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) transformToCommentedImport :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] @@ -116,10 +111,11 @@ transformToCommentedImport is = do accumF accConnectedComm (annMay, decl) = case annMay of Nothing -> ( [] - , [ ImportStatement ImportStatementRecord { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } + , [ ImportStatement ImportStatementRecord + { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } ] ) Just ann -> @@ -131,7 +127,7 @@ transformToCommentedImport is = do :: [(Comment, DeltaPos)] -> [(Comment, DeltaPos)] -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) + go acc [] = ([], acc, 0) go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs go acc ((c1, DP (y, x)) : xs) = @@ -148,8 +144,8 @@ transformToCommentedImport is = do , convertedIndependentComments ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm , importStatement = decl } ] @@ -163,14 +159,14 @@ sortCommentedImports = where unpackImports :: [CommentedImport] -> [CommentedImport] unpackImports xs = xs >>= \case - l@EmptyLine -> [l] + l@EmptyLine -> [l] l@IndependentComment{} -> [l] ImportStatement r -> map IndependentComment (commentsBefore r) ++ [ImportStatement r] mergeGroups :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] mergeGroups xs = xs >>= \case - Left x -> [x] + Left x -> [x] Right y -> ImportStatement <$> y sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups = @@ -180,25 +176,22 @@ sortCommentedImports = groupify cs = go [] cs where go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest + (l@EmptyLine : rest) -> Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] + (ImportStatement r : rest) -> go [r] rest + [] -> [] go acc = \case (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : Right (reverse acc) : go [] rest (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] + [] -> [Right (reverse acc)] commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered commentedImportsToDoc = \case EmptyLine -> docLitS "" IndependentComment c -> commentToDoc c - ImportStatement r -> - docSeq - ( layoutImport (importStatement r) - : map commentToDoc (commentsAfter r) - ) + ImportStatement r -> docSeq + (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) where commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index fd4025a..773d993 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -31,17 +31,15 @@ import Language.Haskell.Brittany.Internal.Types -- the different cases below. layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr - VarPat _ n -> - fmap Seq.singleton $ docLit $ lrdrNameToText n + VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat _ lit -> - fmap Seq.singleton $ allocateNode $ litBriDoc lit + LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr ParPat _ inner -> do -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" + left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" innerDocs <- colsWrapPat =<< layoutPat inner return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right @@ -67,10 +65,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return <$> docLit nameDoc else do x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList - $ sequence - $ spacifyDocs - $ fmap colsWrapPat argDocs + xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap + colsWrapPat + argDocs return $ x1 Seq.<| xR ConPat _ lname (InfixCon left right) -> do -- a :< b -> expr @@ -83,7 +80,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname @@ -96,37 +93,34 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName + , docSeq $ List.intersperse docCommaSep $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName , docSeparator , docLit $ Text.pack "}" ] ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname - Seq.singleton <$> docSeq - [ appSep $ docLit t - , docLit $ Text.pack "{..}" - ] - ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do + Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"] + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) + | dotdoti == length fs -> do -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case (fieldName, Just fieldDoc) -> [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" @@ -134,13 +128,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docCommaSep ] (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] + , docLit $ Text.pack "..}" + ] TuplePat _ args boxity -> do -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR + Boxed -> wrapPatListy args "()" docParenL docParenR Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep AsPat _ asName asPat -> do -- bind@nestedpat -> expr @@ -180,7 +174,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] + Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat @@ -189,9 +183,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend - :: LPat GhcPs - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) + :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of @@ -213,8 +205,5 @@ wrapPatListy elems both start end = do x1 Seq.:< rest -> do sDoc <- start eDoc <- end - rest' <- rest `forM` \bd -> docSeq - [ docCommaSep - , return bd - ] + rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd] return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 7f297fe..5ef19c7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -47,12 +47,12 @@ layoutStmt lstmt@(L _ stmt) = do ] ] LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree + let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" + Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [bindDoc] -> docAlt [ -- let bind = expr docCols @@ -62,9 +62,10 @@ layoutStmt lstmt@(L _ stmt) = do f = case indentPolicy of IndentPolicyFree -> docSetBaseAndIndent IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc + IndentPolicyMultiple + | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc ] , -- let -- bind = expr @@ -78,10 +79,11 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (isFree || indentFourPlus) $ docSeq [ appSep $ docLit $ Text.pack "let" - , let f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs + , let + f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs ] -- let -- aaa = expra @@ -89,8 +91,9 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (not indentFourPlus) $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 208f6b4..1662ffb 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -24,76 +24,63 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsTyVar _ promoted name -> do t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of - IsPromoted -> docSeq - [ docSeparator - , docTick - , docWrapNode name $ docLit t - ] + IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] NotPromoted -> docWrapNode name $ docLit t HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do let bndrs = getBinders hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs forallDoc = docAlt - [ let - open = docLit $ Text.pack "forall" - in docSeq ([open]++tyVarDocLineList) + [ let open = docLit $ Text.pack "forall" + in docSeq ([open] ++ tyVarDocLineList) , docPar - (docLit (Text.pack "forall")) - (docLines - $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ]) + (docLit (Text.pack "forall")) + (docLines $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" + ] + ) ] contextDoc = case cntxtDocs of [] -> docLit $ Text.pack "()" [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] + open = docCols + ColTyOpPrefix + [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) cntxtDoc - ] + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] in docPar open $ docLines $ list ++ [close] ] docAlt -- :: forall a b c . (Foo a b c) => a b -> c [ docSeq [ if null bndrs - then docEmpty - else let + then docEmpty + else + let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) + in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) , docForceSingleline contextDoc , docLit $ Text.pack " => " , docForceSingleline typeDoc @@ -103,75 +90,74 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - forallDoc - ( docLines - [ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) - $ contextDoc - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] + forallDoc + (docLines + [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) $ contextDoc ] - ) + , docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] + ] + ) ] HsForAllTy _ hsf typ2 -> do let bndrs = getBinders hsf typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs docAlt -- forall x . x [ docSeq [ if null bndrs - then docEmpty - else let + then docEmpty + else + let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open]++tyVarDocLineList++[close]) + in docSeq ([open] ++ tyVarDocLineList ++ [close]) , docForceSingleline $ return $ typeDoc ] -- :: forall x -- . x , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ) -- :: forall -- (x :: *) -- . x , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ] - ) - ++[ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> + docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" ] - ] ) + ++ [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ] + ) ] HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do typeDoc <- docSharedWrapper layoutType typ1 @@ -182,29 +168,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) - $ head cntxtDocs - ] + open = docCols + ColTyOpPrefix + [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) - $ cntxtDoc - ] + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] in docPar open $ docLines $ list ++ [close] ] - let maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id docAlt -- (Foo a b c) => a b -> c [ docSeq @@ -216,37 +198,39 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - (docForceSingleline contextDoc) - ( docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) + (docForceSingleline contextDoc) + (docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) ] HsFunTy _ _ typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id hasComments <- hasAnyCommentsBelow ltype - docAlt $ - [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 + docAlt + $ [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 + ] + | not hasComments ] - | not hasComments - ] ++ - [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) - $ maybeForceML typeDoc2 - ] - ) - ] + ++ [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 + ] + ) + ] HsParTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -256,24 +240,28 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack ")" ] , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack ")") + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack ")") ] HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 - final -> (final, list) + let + gather + :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 + final -> (final, list) let (typHead, typRest) = gather [typ2] typ1 docHead <- docSharedWrapper layoutType typHead docRest <- docSharedWrapper layoutType `mapM` typRest docAlt [ docSeq - $ docForceSingleline docHead : (docRest >>= \d -> - [ docSeparator, docForceSingleline d ]) + $ docForceSingleline docHead + : (docRest >>= \d -> [docSeparator, docForceSingleline d]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] HsAppTy _ typ1 typ2 -> do @@ -281,13 +269,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc2 <- docSharedWrapper layoutType typ2 docAlt [ docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docForceSingleline typeDoc2 - ] - , docPar - typeDoc1 - (docEnsureIndent BrIndentRegular typeDoc2) + [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2] + , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) ] HsListTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 @@ -298,51 +281,61 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack "]" ] , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack "]") + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack "]") ] HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where - unboxed = if null typs then error "brittany internal error: unboxed unit" - else unboxedL + unboxed = if null typs + then error "brittany internal error: unboxed unit" + else unboxedL simple = if null typs then unitL else simpleL unitL = docLit $ Text.pack "()" simpleL = do docs <- docSharedWrapper layoutType `mapM` typs - let end = docLit $ Text.pack ")" - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) + let + end = docLit $ Text.pack ")" + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt - [ docSeq $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] + [ docSeq + $ [docLit $ Text.pack "("] + ++ docWrapNodeRest ltype commaDocs + ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) + in + docPar + (docAddBaseY (BrIndentSpecial 2) $ line1) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs - let start = docParenHashLSep - end = docParenHashRSep + let + start = docParenHashLSep + end = docParenHashRSep docAlt - [ docSeq $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] + [ docSeq + $ [start] + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) + ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ lines ++ [end]) @@ -411,20 +404,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq - [ docWrapNodeRest ltype - $ docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + [ docWrapNodeRest ltype $ docLit $ Text.pack + ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") , docForceSingleline typeDoc1 ] , docPar - ( docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) - ) - (docCols ColTyOpPrefix - [ docWrapNodeRest ltype - $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ]) + (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ] + ) ] -- TODO: test KindSig HsKindSig _ typ1 kind1 -> do @@ -465,7 +456,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] else docPar typeDoc1 - ( docCols + (docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) kindDoc1 @@ -536,7 +527,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq - $ [docLit $ Text.pack "'["] + $ [docLit $ Text.pack "'["] ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"] , case splitFirstLast typDocs of @@ -561,19 +552,23 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse + specialCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) + ) ++ [docLit $ Text.pack " ]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> - docCols ColList [specialCommaSep, d] - lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] + lineN = docCols + ColList + [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype @@ -584,8 +579,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy NoSourceText _ -> error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> - docLit $ Text.pack "_" + HsWildCardTy _ -> docLit $ Text.pack "_" HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype HsStarTy _ isUnicode -> do @@ -598,14 +592,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of k <- docSharedWrapper layoutType kind docAlt [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar - t - (docSeq [docLit $ Text.pack "@", k ]) + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar t (docSeq [docLit $ Text.pack "@", k]) ] layoutTyVarBndrs diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs index 8b09fa1..c1bd60a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -18,9 +18,10 @@ obfuscate input = do let predi x = isAlphaNum x || x `elem` "_'" let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x + let + exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x let filtered = filter exceptionFilter idents mappings <- fmap Map.fromList $ filtered `forM` \x -> do r <- createAlias x @@ -72,14 +73,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] createAlias :: String -> IO String createAlias xs = go NoHint xs where - go _hint "" = pure "" - go hint (c : cr) = do + go _hint "" = pure "" + go hint (c : cr) = do c' <- case hint of VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr pure (c' : cr') diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs index d2527e9..394a78d 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -27,12 +27,12 @@ instance Alternative Strict.Maybe where x <|> Strict.Nothing = x _ <|> x = x -traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +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 + traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y (<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) = flip (<$!>) @@ -48,10 +48,10 @@ printErr = putStrErrLn . show errorIf :: Bool -> a -> a errorIf False = id -errorIf True = error "errorIf" +errorIf True = error "errorIf" errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id +errorIfNote Nothing = id errorIfNote (Just x) = error x (<&>) :: Functor f => f a -> (a -> b) -> f b diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 0e5b85f..5cca1ca 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -30,7 +30,7 @@ data AltCurPos = AltCurPos , _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_forceMLFlag :: AltLineModeState } - deriving (Show) + deriving Show data AltLineModeState = AltLineModeStateNone @@ -41,17 +41,18 @@ data AltLineModeState deriving (Show) altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = + AltLineModeStateContradiction altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of @@ -76,7 +77,7 @@ transformAlts = . Memo.startEvalMemoT . fmap unwrapBriDocNumbered . rec - where + where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) -- transWrap :: BriDoc -> BriDocNumbered @@ -114,224 +115,244 @@ transformAlts = - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered - rec bdX@(brDcId, brDc) = do - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> - reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> - reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp - { _acp_indent = ind - , _acp_indentPrep = 0 - } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' - { _acp_line = ind - , _acp_indent = ind - } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( hasSpace1 lconf acp vs && lineCheck vs, bd)) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ]) - $ zip [1..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let lineCheck (VerticalSpacing _ p _) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( any (hasSpace2 lconf acp) vs - && any lineCheck vs, bd)) - let checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do - mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l:lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp - { _acp_line = ind - , _acp_indent = ind - } - rec x - return $ reWrap $ BDFLines (l':lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + rec + :: BriDocNumbered + -> Memo.MemoT + Int + [VerticalSpacing] + (MultiRWSS.MultiRWS r w (AltCurPos ': s)) + BriDocNumbered + rec bdX@(brDcId, brDc) = do + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let + indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd + mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } + sameLine' <- rec sameLine + mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let + lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (hasSpace1 lconf acp vs && lineCheck vs, bd) + ) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust + (\(_i :: Int, (b, x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ] + ) + $ zip [1 ..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let + lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) + ) + let + checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp + { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp + } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet + $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l : lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } + rec x + return $ reWrap $ BDFLines (l' : lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> + reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing _ bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess + $ "transformAlts: BDFDEBUG " + ++ s + ++ " (node-id=" + ++ show brDcId + ++ "): acp=" + ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 + :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + + sameLine + <= confUnpack (_lconfig_cols lconf) + && indent + + indentPrep + + par + <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) getSpacing :: forall m @@ -348,10 +369,11 @@ getSpacing !bridoc = rec bridoc -- BDWrapAnnKey _annKey bd -> rec bd BDFEmpty -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> - return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False - BDFSeq list -> - sumVs <$> rec `mapM` list + BDFLit t -> return $ LineModeValid $ VerticalSpacing + (Text.length t) + VerticalSpacingParNone + False + BDFSeq list -> sumVs <$> rec `mapM` list BDFCols _sig list -> sumVs <$> rec `mapM` list BDFSeparator -> return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False @@ -359,23 +381,23 @@ getSpacing !bridoc = rec bridoc mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) + BrIndentSpecial j -> i + j } BDFBaseYPushCur bd -> do mVs <- rec bd @@ -385,11 +407,13 @@ getSpacing !bridoc = rec bridoc -- the reason is that we really want to _keep_ it Just if it is -- just so we properly communicate the is-multiline fact. -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) , _vs_paragraph = VerticalSpacingParSome 0 } BDFBaseYPop bd -> rec bd @@ -403,86 +427,104 @@ getSpacing !bridoc = rec bridoc | VerticalSpacing lsp mPsp _ <- mVs , indSp <- mIndSp , lineMax <- getMaxVS $ mIndSp - , let pspResult = case mPsp of - VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax - , let parFlagResult = mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp + , let + pspResult = case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp lineMax + , let + parFlagResult = + mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp ] BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> do + BDFAlt (alt : _) -> rec alt + BDFForceMultiline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> LineModeInvalid - _ -> mVs + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> mVs - _ -> LineModeInvalid + _ -> LineModeInvalid BDFForwardLineMode bd -> rec bd BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return - $ LineModeValid - $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_:_) -> do + BDFLines [] -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_ : _) -> do lSps <- rec `mapM` ls - let (mVs:_) = lSps -- separated into let to avoid MonadFail - return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] + let (mVs : _) = lSps -- separated into let to avoid MonadFail + return + $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] BDFEnsureIndent indent bd -> do mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf BDFNonBottomSpacing b bd -> do mVs <- rec bd - return - $ mVs - <|> LineModeValid - (VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) + return $ mVs <|> LineModeValid + (VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } BDFForceParSpacing bd -> do mVs <- rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] BDFDebug s bd -> do r <- rec bd - tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r + tellDebugMess + $ "getSpacing: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): mVs=" + ++ show r return r return result - maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs = foldl' - (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing (max x1 y1) (case (x2, y2) of + (liftM2 + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> @@ -492,9 +534,14 @@ getSpacing !bridoc = rec bridoc (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> VerticalSpacingParAlways $ max i j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) False)) + VerticalSpacingParSome $ max x y + ) + False + ) + ) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing sumVs sps = foldl' (liftM2 go) initial sps where go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing @@ -503,18 +550,19 @@ getSpacing !bridoc = rec bridoc (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y) + VerticalSpacingParSome $ x + y + ) x3 singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False + singleline _ = False isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False + isPar _ = False parFlag = case sps of [] -> True _ -> all singleline (List.init sps) && isPar (List.last sps) @@ -534,374 +582,380 @@ getSpacings -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where + where -- when we do `take K . filter someCondition` on a list of spacings, we -- need to first (also) limit the size of the input list, otherwise a -- _large_ input with a similarly _large_ prefix not passing our filtering -- process could lead to exponential runtime behaviour. -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3*limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let specialCompare vs1 vs2 = - if ( (_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let allowHangingQuasiQuotes = - config - & _conf_layout - & _lconfig_allowHangingQuasiQuotes - & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit - $ [ (x,y) - | x<-mVss - , y<-indSps - ] - return $ mVsIndSp <&> - \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp) - ( mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> - return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1 ] -> VerticalSpacing - (Text.length t1) - VerticalSpacingParNone - False - (t1 : _) -> VerticalSpacing - (Text.length t1) - (VerticalSpacingParAlways 0) - True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_:_) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let worbled = fmap reverse - $ sequence - $ reverse - $ lSpss - sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - sumF [] = error $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then [VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) - return r - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3 * limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let + hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let + specialCompare vs1 vs2 = + if ((_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let + allowHangingQuasiQuotes = + config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = + take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . specialNub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] + return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) - False) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp + ) + (mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1] -> + VerticalSpacing (Text.length t1) VerticalSpacingParNone False + (t1 : _) -> + VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True + | allowHangingQuasiQuotes + ] + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_ : _) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- map filterAndLimit <$> rec `mapM` ls + let + worbled = fmap reverse $ sequence $ reverse $ lSpss + sumF lSps@(lSp1 : _) = + VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False + sumF [] = + error + $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. + mVs <- rec bd + return $ if null mVs + then + [ VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] + else mVs <&> \vs -> vs + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess + $ "getSpacings: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): vs=" + ++ show (take 9 r) + return r + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y + ) + False + ) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y + ) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i fixIndentationForMultiple :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int fixIndentationForMultiple acp indent = do indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i + let + indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i -- for IndentPolicyMultiple, we restrict the amount of added -- indentation in such a manner that we end up on a multiple of the -- base indentation. indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack pure $ if indPolicy == IndentPolicyMultiple then - let indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 + let + indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 3dcdb46..0d2231e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -16,118 +16,147 @@ transformSimplifyColumns = Uniplate.rewrite $ \case -- BDWrapAnnKey annKey $ transformSimplify bd BDEmpty -> Nothing BDLit{} -> Nothing - BDSeq list | any (\case BDSeq{} -> True - BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) - | all (\case BDSeparator -> True; _ -> False) rest -> - Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) - BDLines lines | any (\case BDLines{} -> True - BDEmpty{} -> True - _ -> False) lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDSeq list + | any + (\case + BDSeq{} -> True + BDEmpty{} -> True + _ -> False + ) + list + -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_ : _) : rest) + | all + (\case + BDSeparator -> True + _ -> False + ) + rest + -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)]) + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l x -> [x] -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) -- post floating in BDAnnotationRest annKey1 (BDSeq list) -> Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] -- ensureIndent float-in -- not sure if the following rule is necessary; tests currently are -- unaffected. -- BDEnsureIndent indent (BDLines lines) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines -- matching col special transformation - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) - | sig1==sig2 -> - Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) + | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- | sig1==sig2 -> -- Just $ BDPar -- ind1 -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 (List.init cols ++ [line]) + BDCols sig1 cols + | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 + -> Just + $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] + BDCols sig1 cols + | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 + $ List.init cols + ++ [BDPar ind line (BDLines $ List.init lines)] , BDCols sig2 cols2 ] - BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] - , BDCols sig2 cols2 - ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing BDForceSingleline{} -> Nothing BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing + BDExternal{} -> Nothing + BDPlain{} -> Nothing + BDLines{} -> Nothing BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing + BDDebug{} -> Nothing BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 5ba0ce5..919decf 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -14,10 +14,11 @@ import Language.Haskell.Brittany.Internal.Utils -- note that this is not total, and cannot be with that exact signature. mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = + BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" transformSimplifyFloating :: BriDoc -> BriDoc @@ -27,169 +28,186 @@ transformSimplifyFloating = stepBO .> stepFull -- better complexity. -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> - Just x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> - Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> - Just $ x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + BDAddBaseY BrIndentNone x -> Just x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + BDAddBaseY BrIndentNone x -> Just $ x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 648e7c7..613c5f0 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -27,15 +27,17 @@ transformSimplifyIndent = Uniplate.rewrite $ \case -- [ BDAddBaseY ind x -- , BDEnsureIndent ind indented -- ] - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l - x -> [x] + x -> [x] BDLines [l] -> Just l BDAddBaseY i (BDAnnotationPrior k x) -> Just $ BDAnnotationPrior k (BDAddBaseY i x) @@ -49,4 +51,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY _ lit@BDLit{} -> Just lit - _ -> Nothing + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 2d1abf1..6fe374a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -21,25 +21,28 @@ transformSimplifyPar = transformUp $ \case BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs where go = (=<<) $ \case BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x -- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- BDPar BrIndentNone line indented -> -- Just $ BDLines [line, indented] BDEnsureIndent BrIndentNone x -> x - x -> x + x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index 38f9123..b62028f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -61,24 +61,26 @@ instance (Num a, Ord a) => Semigroup (Max a) where (<>) = Data.Coerce.coerce (max :: a -> a -> a) instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 + mempty = Max 0 mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data -instance Show ShowIsId where show (ShowIsId x) = x +instance Show ShowIsId where + show (ShowIsId x) = x -data A x = A ShowIsId x deriving Data +data A x = A ShowIsId x + deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -86,18 +88,22 @@ customLayouterF anns layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter + srcSpan ss = + simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" ++ showOutputable ss ++ "}" + $ "{" + ++ showOutputable ss + ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where @@ -109,12 +115,12 @@ customLayouterF anns layoutF = customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -122,14 +128,15 @@ customLayouterNoAnnsF layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter @@ -193,12 +200,11 @@ traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () -tellDebugMess :: MonadMultiWriter - (Seq String) m => String -> m () +tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s -tellDebugMessShow :: forall a m . (MonadMultiWriter - (Seq String) m, Show a) => a -> m () +tellDebugMessShow + :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. @@ -213,29 +219,28 @@ briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) +annsDoc = + printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1:aR) = case fn a1 of - Left b -> (b : bs, cs) +breakEither _ [] = ([], []) +breakEither fn (a1 : aR) = case fn a1 of + Left b -> (b : bs, cs) Right c -> (bs, c : cs) - where - (bs, cs) = breakEither fn aR + where (bs, cs) = breakEither fn aR spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) - where - (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) +spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) + where (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) data FirstLastView a = FirstLastEmpty @@ -245,7 +250,7 @@ data FirstLastView a splitFirstLast :: [a] -> FirstLastView a splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) +splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) -- TODO: move to uniplate upstream? -- aka `transform` @@ -264,7 +269,7 @@ lines' :: String -> [String] lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] - (s1, (_:r)) -> s1 : lines' r + (s1, (_ : r)) -> s1 : lines' r absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index ca9fc7b..e599fc2 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -105,7 +105,7 @@ helpDoc = PP.vcat $ List.intersperse ] , parDoc $ "See https://github.com/lspitzner/brittany" , parDoc - $ "Please report bugs at" + $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" ] @@ -142,15 +142,16 @@ mainCmdParser helpDesc = do addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser + configPaths <- addFlagStringParams + "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] @@ -176,7 +177,7 @@ mainCmdParser helpDesc = do "" ["write-mode"] "(display|inplace)" - ( flagHelp + (flagHelp (PP.vcat [ PP.text "display: output for any input(s) goes to stdout" , PP.text "inplace: override respective input file (without backup!)" @@ -206,11 +207,12 @@ mainCmdParser helpDesc = do $ ppHelpShallow helpDesc System.Exit.exitSuccess - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths + let + inputPaths = if null inputParams then [Nothing] else map Just inputParams + let + outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths configsToLoad <- liftIO $ if null configPaths then @@ -225,14 +227,15 @@ mainCmdParser helpDesc = do ) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x + Just x -> return x when (config & _conf_debug & _dconf_dump_config & confUnpack) $ trace (showConfigYaml config) $ return () - results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths + results <- zipWithM + (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths if checkMode then when (Changes `elem` (Data.Either.rights results)) @@ -268,51 +271,57 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = -- 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 + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack -- the flag will do the following: insert a marker string -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- "#include" before processing (parsing) input; and remove that marker -- string from the transformation output. -- The flag is intentionally misspelled to prevent clashing with -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + let + hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let + exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id + let + hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let + hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id inputString <- liftIO System.IO.getContents - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) + parseRes <- liftIO $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) return (parseRes, Text.pack inputString) Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc + parseRes <- parseModule ghcOptions p cppCheckFunc inputText <- Text.IO.readFile p -- The above means we read the file twice, but the -- GHC API does not really expose the source it @@ -343,8 +352,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () - let disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack + let + disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack (errsWarns, outSText, hasChanges) <- do if | disableFormatting -> do @@ -353,46 +363,52 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let r = Text.pack $ ExactPrint.exactPrint parsedSource anns pure ([], r, r /= originalContents) | otherwise -> do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let + omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - else outRaw + else liftIO $ pPrintModuleAndCheck + moduleConf + perItemConf + anns + parsedSource + let + hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let + out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out pure $ (ews, out', out' /= originalContents) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 unless (null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns + let + groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns groupedErrsWarns `forM_` \case (ErrorOutputCheck{} : _) -> do putErrorLn - $ "ERROR: brittany pretty printer" + $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str @@ -403,7 +419,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = ErrorUnknownNode str ast@(L loc _) -> do putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) when - ( config + (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack @@ -417,17 +433,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = putErrorLn $ "WARNINGS:" warns `forM_` \case LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" unused@(ErrorUnusedComment{} : _) -> do putErrorLn - $ "Error: detected unprocessed comments." + $ "Error: detected unprocessed comments." ++ " The transformation output will most likely" ++ " not contain some of the comments" ++ " present in the input haskell source file." putErrorLn $ "Affected are the following comments:" unused `forM_` \case ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" (ErrorMacroConfig err input : _) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err @@ -438,8 +454,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let hasErrors = if config & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) outputOnErrs = config & _conf_errorHandling @@ -454,10 +470,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ addTraceSep (_conf_debug config) $ case outputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges + Just p -> liftIO $ do + let + isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText when (checkMode && hasChanges) $ case inputPathM of @@ -469,15 +486,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = where addTraceSep conf = if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] then trace "----" else id -- 2.30.2 From ccabed9d7b489b172a8f80773d062be03e4836a9 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 29 Nov 2021 12:18:38 +0000 Subject: [PATCH 468/478] Use new czipwith from Hackage --- cabal.project | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/cabal.project b/cabal.project index 6d724ea..39d048c 100644 --- a/cabal.project +++ b/cabal.project @@ -1,12 +1,9 @@ packages: . allow-newer: + -- https://github.com/lspitzner/butcher/issues/7 , butcher:base + -- https://github.com/lspitzner/data-tree-print/pull/2 , data-tree-print:base + -- https://github.com/lspitzner/multistate/pull/8 , multistate:base - --- https://github.com/lspitzner/czipwith/pull/2 -source-repository-package - type: git - location: https://github.com/mithrandi/czipwith - tag: b6245884ae83e00dd2b5261762549b37390179f8 -- 2.30.2 From 9e12a36a4f578c2ac78ff8c54ee518bb3b2f087f Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 29 Nov 2021 12:20:51 +0000 Subject: [PATCH 469/478] Also build on `master` branch --- .github/workflows/ci.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 11b88e8..0e0f3d7 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -3,9 +3,11 @@ on: pull_request: branches: - main + - master push: branches: - main + - master release: types: - created -- 2.30.2 From 6151ba5825162d2ebdfadac48908da32b959ccdb Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 29 Nov 2021 12:21:18 +0000 Subject: [PATCH 470/478] Upgrade to ghcup 0.1.17.4 --- .devcontainer/Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index bccc565..2098c57 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -6,7 +6,7 @@ RUN \ apt-get update && \ apt-get install --assume-yes curl gcc git libgmp-dev libtinfo-dev make sudo -ARG GHCUP_VERSION=0.1.17.3 +ARG GHCUP_VERSION=0.1.17.4 RUN \ curl --output /usr/local/bin/ghcup "https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION" && \ chmod +x /usr/local/bin/ghcup && \ -- 2.30.2 From 2fe1432631ac103284729c9afbbf0b0045228150 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 29 Nov 2021 12:25:00 +0000 Subject: [PATCH 471/478] Remove `Language.Haskell.` from module names --- brittany.cabal | 60 +++++++++---------- source/executable/Main.hs | 2 +- .../{Language/Haskell => }/Brittany.hs | 10 ++-- .../Haskell => }/Brittany/Internal.hs | 36 +++++------ .../Haskell => }/Brittany/Internal/Backend.hs | 16 ++--- .../Brittany/Internal/BackendUtils.hs | 12 ++-- .../Haskell => }/Brittany/Internal/Config.hs | 12 ++-- .../Brittany/Internal/Config/Types.hs | 6 +- .../Internal/Config/Types/Instances.hs | 6 +- .../Brittany/Internal/ExactPrintUtils.hs | 10 ++-- .../Brittany/Internal/LayouterBasics.hs | 14 ++--- .../Brittany/Internal/Layouters/DataDecl.hs | 14 ++--- .../Brittany/Internal/Layouters/Decl.hs | 24 ++++---- .../Brittany/Internal/Layouters/Expr.hs | 22 +++---- .../Brittany/Internal/Layouters/Expr.hs-boot | 4 +- .../Brittany/Internal/Layouters/IE.hs | 10 ++-- .../Brittany/Internal/Layouters/Import.hs | 14 ++--- .../Brittany/Internal/Layouters/Module.hs | 16 ++--- .../Brittany/Internal/Layouters/Pattern.hs | 14 ++--- .../Brittany/Internal/Layouters/Stmt.hs | 18 +++--- .../Brittany/Internal/Layouters/Stmt.hs-boot | 4 +- .../Brittany/Internal/Layouters/Type.hs | 12 ++-- .../Brittany/Internal/Obfuscation.hs | 6 +- .../Brittany/Internal/ParseModule.hs | 2 +- .../Haskell => }/Brittany/Internal/Prelude.hs | 2 +- .../Brittany/Internal/PreludeUtils.hs | 2 +- .../Brittany/Internal/Transformations/Alt.hs | 12 ++-- .../Internal/Transformations/Columns.hs | 6 +- .../Internal/Transformations/Floating.hs | 10 ++-- .../Internal/Transformations/Indent.hs | 6 +- .../Brittany/Internal/Transformations/Par.hs | 8 +-- .../Haskell => }/Brittany/Internal/Types.hs | 6 +- .../Haskell => }/Brittany/Internal/Utils.hs | 10 ++-- .../{Language/Haskell => }/Brittany/Main.hs | 18 +++--- source/test-suite/Main.hs | 2 +- 35 files changed, 213 insertions(+), 213 deletions(-) rename source/library/{Language/Haskell => }/Brittany.hs (63%) rename source/library/{Language/Haskell => }/Brittany/Internal.hs (95%) rename source/library/{Language/Haskell => }/Brittany/Internal/Backend.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/BackendUtils.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/Config.hs (97%) rename source/library/{Language/Haskell => }/Brittany/Internal/Config/Types.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/Config/Types/Instances.hs (96%) rename source/library/{Language/Haskell => }/Brittany/Internal/ExactPrintUtils.hs (96%) rename source/library/{Language/Haskell => }/Brittany/Internal/LayouterBasics.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/DataDecl.hs (97%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Decl.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Expr.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Expr.hs-boot (67%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/IE.hs (96%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Import.hs (94%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Module.hs (94%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Pattern.hs (95%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Stmt.hs (87%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Stmt.hs-boot (50%) rename source/library/{Language/Haskell => }/Brittany/Internal/Layouters/Type.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/Obfuscation.hs (93%) rename source/library/{Language/Haskell => }/Brittany/Internal/ParseModule.hs (99%) rename source/library/{Language/Haskell => }/Brittany/Internal/Prelude.hs (98%) rename source/library/{Language/Haskell => }/Brittany/Internal/PreludeUtils.hs (96%) rename source/library/{Language/Haskell => }/Brittany/Internal/Transformations/Alt.hs (99%) rename source/library/{Language/Haskell => }/Brittany/Internal/Transformations/Columns.hs (96%) rename source/library/{Language/Haskell => }/Brittany/Internal/Transformations/Floating.hs (97%) rename source/library/{Language/Haskell => }/Brittany/Internal/Transformations/Indent.hs (91%) rename source/library/{Language/Haskell => }/Brittany/Internal/Transformations/Par.hs (85%) rename source/library/{Language/Haskell => }/Brittany/Internal/Types.hs (99%) rename source/library/{Language/Haskell => }/Brittany/Internal/Utils.hs (97%) rename source/library/{Language/Haskell => }/Brittany/Main.hs (97%) diff --git a/brittany.cabal b/brittany.cabal index 45b6a65..c95544f 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -101,36 +101,36 @@ library autogen-modules: Paths_brittany hs-source-dirs: source/library exposed-modules: - Language.Haskell.Brittany - Language.Haskell.Brittany.Internal - Language.Haskell.Brittany.Internal.Backend - Language.Haskell.Brittany.Internal.BackendUtils - Language.Haskell.Brittany.Internal.Config - Language.Haskell.Brittany.Internal.Config.Types - Language.Haskell.Brittany.Internal.Config.Types.Instances - Language.Haskell.Brittany.Internal.ExactPrintUtils - Language.Haskell.Brittany.Internal.LayouterBasics - Language.Haskell.Brittany.Internal.Layouters.DataDecl - Language.Haskell.Brittany.Internal.Layouters.Decl - Language.Haskell.Brittany.Internal.Layouters.Expr - Language.Haskell.Brittany.Internal.Layouters.IE - Language.Haskell.Brittany.Internal.Layouters.Import - Language.Haskell.Brittany.Internal.Layouters.Module - Language.Haskell.Brittany.Internal.Layouters.Pattern - Language.Haskell.Brittany.Internal.Layouters.Stmt - Language.Haskell.Brittany.Internal.Layouters.Type - Language.Haskell.Brittany.Internal.Obfuscation - Language.Haskell.Brittany.Internal.ParseModule - Language.Haskell.Brittany.Internal.Prelude - Language.Haskell.Brittany.Internal.PreludeUtils - Language.Haskell.Brittany.Internal.Transformations.Alt - Language.Haskell.Brittany.Internal.Transformations.Columns - Language.Haskell.Brittany.Internal.Transformations.Floating - Language.Haskell.Brittany.Internal.Transformations.Indent - Language.Haskell.Brittany.Internal.Transformations.Par - Language.Haskell.Brittany.Internal.Types - Language.Haskell.Brittany.Internal.Utils - Language.Haskell.Brittany.Main + Brittany + Brittany.Internal + Brittany.Internal.Backend + Brittany.Internal.BackendUtils + Brittany.Internal.Config + Brittany.Internal.Config.Types + Brittany.Internal.Config.Types.Instances + Brittany.Internal.ExactPrintUtils + Brittany.Internal.LayouterBasics + Brittany.Internal.Layouters.DataDecl + Brittany.Internal.Layouters.Decl + Brittany.Internal.Layouters.Expr + Brittany.Internal.Layouters.IE + Brittany.Internal.Layouters.Import + Brittany.Internal.Layouters.Module + Brittany.Internal.Layouters.Pattern + Brittany.Internal.Layouters.Stmt + Brittany.Internal.Layouters.Type + Brittany.Internal.Obfuscation + Brittany.Internal.ParseModule + Brittany.Internal.Prelude + Brittany.Internal.PreludeUtils + Brittany.Internal.Transformations.Alt + Brittany.Internal.Transformations.Columns + Brittany.Internal.Transformations.Floating + Brittany.Internal.Transformations.Indent + Brittany.Internal.Transformations.Par + Brittany.Internal.Types + Brittany.Internal.Utils + Brittany.Main Paths_brittany executable brittany diff --git a/source/executable/Main.hs b/source/executable/Main.hs index 7a5ae94..6abfcca 100644 --- a/source/executable/Main.hs +++ b/source/executable/Main.hs @@ -1,4 +1,4 @@ -import qualified Language.Haskell.Brittany.Main as BrittanyMain +import qualified Brittany.Main as BrittanyMain main :: IO () main = BrittanyMain.main diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Brittany.hs similarity index 63% rename from source/library/Language/Haskell/Brittany.hs rename to source/library/Brittany.hs index a2726c8..d7630ba 100644 --- a/source/library/Language/Haskell/Brittany.hs +++ b/source/library/Brittany.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany +module Brittany ( parsePrintModule , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled @@ -18,7 +18,7 @@ module Language.Haskell.Brittany , BrittanyError(..) ) where -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal +import Brittany.Internal.Config +import Brittany.Internal.Config.Types +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Brittany/Internal.hs similarity index 95% rename from source/library/Language/Haskell/Brittany/Internal.hs rename to source/library/Brittany/Internal.hs index 06cbb63..e73bcef 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Brittany/Internal.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal +module Brittany.Internal ( parsePrintModule , parsePrintModuleTests , pPrintModule @@ -36,23 +36,23 @@ import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List import GHC.Parser.Annotation (AnnKeywordId(..)) import GHC.Types.SrcLoc (SrcSpan) -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Indent -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Backend +import Brittany.Internal.BackendUtils +import Brittany.Internal.Config +import Brittany.Internal.Config.Types +import Brittany.Internal.ExactPrintUtils +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Layouters.Decl +import Brittany.Internal.Layouters.Module +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Transformations.Alt +import Brittany.Internal.Transformations.Columns +import Brittany.Internal.Transformations.Floating +import Brittany.Internal.Transformations.Indent +import Brittany.Internal.Transformations.Par +import Brittany.Internal.Types +import Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified UI.Butcher.Monadic as Butcher diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Brittany/Internal/Backend.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/Backend.hs rename to source/library/Brittany/Internal/Backend.hs index 55a3c97..35fb3c2 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Brittany/Internal/Backend.hs @@ -4,7 +4,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Backend where +module Brittany.Internal.Backend where import qualified Control.Monad.Trans.State.Strict as StateS import qualified Data.Either as Either @@ -19,13 +19,13 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.BackendUtils +import Brittany.Internal.Config.Types +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Brittany/Internal/BackendUtils.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs rename to source/library/Brittany/Internal/BackendUtils.hs index 310ea56..dbadef4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Brittany/Internal/BackendUtils.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.BackendUtils where +module Brittany.Internal.BackendUtils where import qualified Data.Data import qualified Data.Either @@ -12,11 +12,11 @@ import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder import GHC (Located) import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Config.Types +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Brittany/Internal/Config.hs similarity index 97% rename from source/library/Language/Haskell/Brittany/Internal/Config.hs rename to source/library/Brittany/Internal/Config.hs index 040320b..0f62c26 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Brittany/Internal/Config.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Config where +module Brittany.Internal.Config where import qualified Data.Bool as Bool import qualified Data.ByteString as ByteString @@ -12,11 +12,11 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Semigroup as Semigroup import qualified Data.Yaml import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances () -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Config.Types +import Brittany.Internal.Config.Types.Instances () +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Utils import qualified System.Console.CmdArgs.Explicit as CmdArgs import qualified System.Directory import qualified System.Directory as Directory diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Brittany/Internal/Config/Types.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/Config/Types.hs rename to source/library/Brittany/Internal/Config/Types.hs index 0f0075a..aed9f2c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Brittany/Internal/Config/Types.hs @@ -5,7 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -module Language.Haskell.Brittany.Internal.Config.Types where +module Brittany.Internal.Config.Types where import Data.CZipWith import Data.Coerce (Coercible, coerce) @@ -14,8 +14,8 @@ import qualified Data.Semigroup as Semigroup import Data.Semigroup (Last) import Data.Semigroup.Generic import GHC.Generics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils () +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils () diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Brittany/Internal/Config/Types/Instances.hs similarity index 96% rename from source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs rename to source/library/Brittany/Internal/Config/Types/Instances.hs index c667038..ef7113b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Brittany/Internal/Config/Types/Instances.hs @@ -16,13 +16,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Config.Types.Instances where +module Brittany.Internal.Config.Types.Instances where import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson import Data.Yaml -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude +import Brittany.Internal.Config.Types +import Brittany.Internal.Prelude diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Brittany/Internal/ExactPrintUtils.hs similarity index 96% rename from source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs rename to source/library/Brittany/Internal/ExactPrintUtils.hs index 63d6b53..863c1fd 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Brittany/Internal/ExactPrintUtils.hs @@ -5,7 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.ExactPrintUtils where +module Brittany.Internal.ExactPrintUtils where import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS @@ -23,10 +23,10 @@ import qualified GHC.Driver.CmdLine as GHC import GHC.Hs import qualified GHC.Types.SrcLoc as GHC import GHC.Types.SrcLoc (Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Brittany.Internal.Config.Types +import qualified Brittany.Internal.ParseModule as ParseModule +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified System.IO diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Brittany/Internal/LayouterBasics.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs rename to source/library/Brittany/Internal/LayouterBasics.hs index 136468e..d4e883b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Brittany/Internal/LayouterBasics.hs @@ -4,7 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.LayouterBasics where +module Brittany.Internal.LayouterBasics where import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Writer.Strict as Writer @@ -24,12 +24,12 @@ import GHC.Types.Name (getOccString) import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader (RdrName(..)) import qualified GHC.Types.SrcLoc as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Config.Types +import Brittany.Internal.ExactPrintUtils +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Brittany/Internal/Layouters/DataDecl.hs similarity index 97% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs rename to source/library/Brittany/Internal/Layouters/DataDecl.hs index 37f648e..8ed54ff 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Brittany/Internal/Layouters/DataDecl.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.DataDecl where +module Brittany.Internal.Layouters.DataDecl where import qualified Data.Data import qualified Data.Semigroup as Semigroup @@ -10,12 +10,12 @@ import GHC (GenLocated(L), Located) import qualified GHC import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Config.Types +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Layouters.Type +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Brittany/Internal/Layouters/Decl.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs rename to source/library/Brittany/Internal/Layouters/Decl.hs index 9e22b6e..fd55956 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Brittany/Internal/Layouters/Decl.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Layouters.Decl where +module Brittany.Internal.Layouters.Decl where import qualified Data.Data import qualified Data.Foldable @@ -23,17 +23,17 @@ import GHC.Types.Basic , RuleMatchInfo(..) ) import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Config.Types +import Brittany.Internal.ExactPrintUtils +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Layouters.DataDecl +import {-# SOURCE #-} Brittany.Internal.Layouters.Expr +import Brittany.Internal.Layouters.Pattern +import {-# SOURCE #-} Brittany.Internal.Layouters.Stmt +import Brittany.Internal.Layouters.Type +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Brittany/Internal/Layouters/Expr.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs rename to source/library/Brittany/Internal/Layouters/Expr.hs index 138a748..0b34383 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Brittany/Internal/Layouters/Expr.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Expr where +module Brittany.Internal.Layouters.Expr where import qualified Data.Data import qualified Data.Semigroup as Semigroup @@ -14,16 +14,16 @@ import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic import GHC.Types.Name -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Config.Types +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Layouters.Decl +import Brittany.Internal.Layouters.Pattern +import Brittany.Internal.Layouters.Stmt +import Brittany.Internal.Layouters.Type +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Brittany/Internal/Layouters/Expr.hs-boot similarity index 67% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot rename to source/library/Brittany/Internal/Layouters/Expr.hs-boot index 4f913c3..bfe60e4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Brittany/Internal/Layouters/Expr.hs-boot @@ -1,9 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Expr where +module Brittany.Internal.Layouters.Expr where import GHC.Hs -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Brittany/Internal/Layouters/IE.hs similarity index 96% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs rename to source/library/Brittany/Internal/Layouters/IE.hs index 8684842..d1da317 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Brittany/Internal/Layouters/IE.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.IE where +module Brittany.Internal.Layouters.IE where import qualified Data.List.Extra import qualified Data.Text as Text @@ -16,10 +16,10 @@ import GHC ) import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Prelude +import Brittany.Internal.Types +import Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Brittany/Internal/Layouters/Import.hs similarity index 94% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs rename to source/library/Brittany/Internal/Layouters/Import.hs index fc17cde..93e7d83 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Brittany/Internal/Layouters/Import.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Import where +module Brittany.Internal.Layouters.Import where import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text @@ -8,12 +8,12 @@ import GHC (GenLocated(L), Located, moduleNameString, unLoc) import GHC.Hs import GHC.Types.Basic import GHC.Unit.Types (IsBootInterface(..)) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Config.Types +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Layouters.IE +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Brittany/Internal/Layouters/Module.hs similarity index 94% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs rename to source/library/Brittany/Internal/Layouters/Module.hs index 8de45d7..2a6cdbb 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Brittany/Internal/Layouters/Module.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Module where +module Brittany.Internal.Layouters.Module where import qualified Data.Maybe import qualified Data.Semigroup as Semigroup @@ -9,13 +9,13 @@ import qualified Data.Text as Text import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Config.Types +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Layouters.IE +import Brittany.Internal.Layouters.Import +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types import Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos(..), commentContents, deltaRow) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Brittany/Internal/Layouters/Pattern.hs similarity index 95% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs rename to source/library/Brittany/Internal/Layouters/Pattern.hs index 773d993..0d31ecb 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Brittany/Internal/Layouters/Pattern.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Pattern where +module Brittany.Internal.Layouters.Pattern where import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq @@ -10,12 +10,12 @@ import GHC (GenLocated(L), ol_val) import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic -import Language.Haskell.Brittany.Internal.LayouterBasics -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.LayouterBasics +import {-# SOURCE #-} Brittany.Internal.Layouters.Expr +import Brittany.Internal.Layouters.Type +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Brittany/Internal/Layouters/Stmt.hs similarity index 87% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs rename to source/library/Brittany/Internal/Layouters/Stmt.hs index 5ef19c7..729e3ef 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Brittany/Internal/Layouters/Stmt.hs @@ -2,20 +2,20 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Layouters.Stmt where +module Brittany.Internal.Layouters.Stmt where import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import GHC (GenLocated(L)) import GHC.Hs -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Config.Types +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Layouters.Decl +import {-# SOURCE #-} Brittany.Internal.Layouters.Expr +import Brittany.Internal.Layouters.Pattern +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Brittany/Internal/Layouters/Stmt.hs-boot similarity index 50% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot rename to source/library/Brittany/Internal/Layouters/Stmt.hs-boot index 6cfd5c8..0c1cf13 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/source/library/Brittany/Internal/Layouters/Stmt.hs-boot @@ -1,9 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Stmt where +module Brittany.Internal.Layouters.Stmt where import GHC.Hs -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Brittany/Internal/Layouters/Type.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs rename to source/library/Brittany/Internal/Layouters/Type.hs index 1662ffb..a19be50 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Brittany/Internal/Layouters/Type.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Type where +module Brittany.Internal.Layouters.Type where import qualified Data.Text as Text import GHC (AnnKeywordId(..), GenLocated(L)) @@ -9,11 +9,11 @@ import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic import GHC.Utils.Outputable (ftext, showSDocUnsafe) -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils (FirstLastView(..), splitFirstLast) diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Brittany/Internal/Obfuscation.hs similarity index 93% rename from source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs rename to source/library/Brittany/Internal/Obfuscation.hs index c1bd60a..6ec2320 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Brittany/Internal/Obfuscation.hs @@ -1,14 +1,14 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Obfuscation where +module Brittany.Internal.Obfuscation where import Data.Char import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils import System.Random diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Brittany/Internal/ParseModule.hs similarity index 99% rename from source/library/Language/Haskell/Brittany/Internal/ParseModule.hs rename to source/library/Brittany/Internal/ParseModule.hs index 2cc259f..1a1ea51 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs +++ b/source/library/Brittany/Internal/ParseModule.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-implicit-prelude #-} -module Language.Haskell.Brittany.Internal.ParseModule where +module Brittany.Internal.ParseModule where import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as IO diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Brittany/Internal/Prelude.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/Prelude.hs rename to source/library/Brittany/Internal/Prelude.hs index 8198533..a130166 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/source/library/Brittany/Internal/Prelude.hs @@ -1,4 +1,4 @@ -module Language.Haskell.Brittany.Internal.Prelude +module Brittany.Internal.Prelude ( module E ) where diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Brittany/Internal/PreludeUtils.hs similarity index 96% rename from source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs rename to source/library/Brittany/Internal/PreludeUtils.hs index 394a78d..1a6f5e4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Brittany/Internal/PreludeUtils.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Haskell.Brittany.Internal.PreludeUtils where +module Brittany.Internal.PreludeUtils where import Control.Applicative import Control.DeepSeq (NFData, force) diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Brittany/Internal/Transformations/Alt.hs similarity index 99% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs rename to source/library/Brittany/Internal/Transformations/Alt.hs index 5cca1ca..00a242e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Brittany/Internal/Transformations/Alt.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -module Language.Haskell.Brittany.Internal.Transformations.Alt where +module Brittany.Internal.Transformations.Alt where import qualified Control.Monad.Memo as Memo import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS @@ -16,11 +16,11 @@ import qualified Data.List.Extra import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Config.Types +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Brittany/Internal/Transformations/Columns.hs similarity index 96% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs rename to source/library/Brittany/Internal/Transformations/Columns.hs index 0d2231e..a43bd69 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Brittany/Internal/Transformations/Columns.hs @@ -1,12 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Columns where +module Brittany.Internal.Transformations.Columns where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Prelude +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Brittany/Internal/Transformations/Floating.hs similarity index 97% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs rename to source/library/Brittany/Internal/Transformations/Floating.hs index 919decf..37d0b43 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Brittany/Internal/Transformations/Floating.hs @@ -1,14 +1,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Floating where +module Brittany.Internal.Transformations.Floating where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Brittany/Internal/Transformations/Indent.hs similarity index 91% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs rename to source/library/Brittany/Internal/Transformations/Indent.hs index 613c5f0..da0b102 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Brittany/Internal/Transformations/Indent.hs @@ -1,12 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Indent where +module Brittany.Internal.Transformations.Indent where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Prelude +import Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Brittany/Internal/Transformations/Par.hs similarity index 85% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs rename to source/library/Brittany/Internal/Transformations/Par.hs index 6fe374a..dda3329 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Brittany/Internal/Transformations/Par.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Par where +module Brittany.Internal.Transformations.Par where -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal.Prelude +import Brittany.Internal.Types +import Brittany.Internal.Utils diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Brittany/Internal/Types.hs similarity index 99% rename from source/library/Language/Haskell/Brittany/Internal/Types.hs rename to source/library/Brittany/Internal/Types.hs index 6a2c8af..d8b1f44 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Brittany/Internal/Types.hs @@ -10,7 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -module Language.Haskell.Brittany.Internal.Types where +module Brittany.Internal.Types where import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data @@ -19,8 +19,8 @@ import qualified Data.Kind as Kind import qualified Data.Strict.Maybe as Strict import qualified Data.Text.Lazy.Builder as Text.Builder import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude +import Brittany.Internal.Config.Types +import Brittany.Internal.Prelude import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint (AnnKey) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Brittany/Internal/Utils.hs similarity index 97% rename from source/library/Language/Haskell/Brittany/Internal/Utils.hs rename to source/library/Brittany/Internal/Utils.hs index b62028f..1210c98 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Brittany/Internal/Utils.hs @@ -5,7 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Utils where +module Brittany.Internal.Utils where import qualified Data.ByteString as B import qualified Data.Coerce @@ -22,10 +22,10 @@ import qualified GHC.OldList as List import GHC.Types.Name.Occurrence as OccName (occNameString) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Brittany.Internal.Config.Types +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Text.PrettyPrint as PP diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Brittany/Main.hs similarity index 97% rename from source/library/Language/Haskell/Brittany/Main.hs rename to source/library/Brittany/Main.hs index e599fc2..fe25bf2 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Brittany/Main.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Main where +module Brittany.Main where import Control.Monad (zipWithM) import qualified Control.Monad.Trans.Except as ExceptT @@ -20,14 +20,14 @@ import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Obfuscation -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Brittany.Internal +import Brittany.Internal.Config +import Brittany.Internal.Config.Types +import Brittany.Internal.Obfuscation +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Paths_brittany import qualified System.Directory as Directory diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index e48ec56..7ff05a4 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -1,6 +1,6 @@ import qualified Control.Monad as Monad import qualified Data.List as List -import qualified Language.Haskell.Brittany.Main as Brittany +import qualified Brittany.Main as Brittany import qualified System.Directory as Directory import qualified System.FilePath as FilePath import qualified Test.Hspec as Hspec -- 2.30.2 From 6b1e6fa73a89f5cf82eff7b042c32a58921f9fa8 Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 1 Dec 2021 20:51:51 +0100 Subject: [PATCH 472/478] Update README to mention HLS instead of HIE --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 76ad1bf..7183861 100644 --- a/README.md +++ b/README.md @@ -104,8 +104,8 @@ log the size of the input, but _not_ the full input/output of requests.) #### VSCode [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGabriel. -#### Via HIE - [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) +#### Via HLS + [haskell-language-server](https://github.com/haskell/haskell-language-server) includes a `brittany` plugin that directly uses the brittany library. Relevant for any editors that properly support the language-server-protocol. #### Neovim / Vim 8 -- 2.30.2 From ad88ba3f5757daec9e403babfe5c8a99f1e67134 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Wed, 5 Jan 2022 07:48:36 -0500 Subject: [PATCH 473/478] Update Stack resolver Fixes #361. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 7183861..254c7a4 100644 --- a/README.md +++ b/README.md @@ -61,7 +61,7 @@ log the size of the input, but _not_ the full input/output of requests.) - via `stack` ~~~~.sh - stack install brittany # --resolver lts-10.0 + stack install brittany # --resolver lts-16.31 ~~~~ If you use an lts that includes brittany this should just work; otherwise -- 2.30.2 From 3996efd5eb27ae7a3e3eb9ff1bde66cfda28aff9 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Thu, 6 Jan 2022 23:57:07 +0000 Subject: [PATCH 474/478] =?UTF-8?q?Use=20defaultDynFlags=20to=20obtain=20g?= =?UTF-8?q?hc=E2=80=99s=20DynFlags?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This way brittany can avoid dealing with incompatibilities in DynFlags structure between ghc versions (e.g. different versions having different fields). --- .../Haskell/Brittany/Internal/ParseModule.hs | 230 ++---------------- 1 file changed, 23 insertions(+), 207 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs index 2cc259f..8ab3630 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs @@ -1,29 +1,21 @@ {-# OPTIONS_GHC -Wno-implicit-prelude #-} -module Language.Haskell.Brittany.Internal.ParseModule where +module Language.Haskell.Brittany.Internal.ParseModule (parseModule) where import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as IO import qualified Control.Monad.Trans.Except as Except -import qualified Data.Set as Set import qualified GHC import qualified GHC.ByteOrder import qualified GHC.Data.Bag -import qualified GHC.Data.EnumSet import qualified GHC.Data.StringBuffer import qualified GHC.Driver.Session import qualified GHC.Parser.Header import qualified GHC.Platform import qualified GHC.Settings -import qualified GHC.Types.Basic import qualified GHC.Types.SrcLoc -import qualified GHC.Unit.Module.Name -import qualified GHC.Unit.State -import qualified GHC.Unit.Types import qualified GHC.Utils.Error import qualified GHC.Utils.Fingerprint -import qualified GHC.Utils.Misc -import qualified GHC.Utils.Ppr.Colour import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint @@ -77,184 +69,18 @@ handleErrorMessages handleErrorMessages = Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList -initialCfgWeights :: GHC.Driver.Session.CfgWeights -initialCfgWeights = GHC.Driver.Session.CFGWeights - { GHC.Driver.Session.backEdgeBonus = 0 - , GHC.Driver.Session.callWeight = 0 - , GHC.Driver.Session.condBranchWeight = 0 - , GHC.Driver.Session.infoTablePenalty = 0 - , GHC.Driver.Session.likelyCondWeight = 0 - , GHC.Driver.Session.switchWeight = 0 - , GHC.Driver.Session.uncondWeight = 0 - , GHC.Driver.Session.unlikelyCondWeight = 0 - } - initialDynFlags :: GHC.Driver.Session.DynFlags -initialDynFlags = GHC.Driver.Session.DynFlags - { GHC.Driver.Session.avx = False - , GHC.Driver.Session.avx2 = False - , GHC.Driver.Session.avx512cd = False - , GHC.Driver.Session.avx512er = False - , GHC.Driver.Session.avx512f = False - , GHC.Driver.Session.avx512pf = False - , GHC.Driver.Session.binBlobThreshold = 0 - , GHC.Driver.Session.bmiVersion = Nothing - , GHC.Driver.Session.cachedPlugins = [] - , GHC.Driver.Session.canGenerateDynamicToo = error "canGenerateDynamicToo" - , GHC.Driver.Session.canUseColor = False - , GHC.Driver.Session.cfgWeightInfo = initialCfgWeights - , GHC.Driver.Session.cmdlineFrameworks = [] - , GHC.Driver.Session.cmmProcAlignment = Nothing - , GHC.Driver.Session.colScheme = GHC.Utils.Ppr.Colour.defaultScheme - , GHC.Driver.Session.debugLevel = 0 - , GHC.Driver.Session.depExcludeMods = [] - , GHC.Driver.Session.depIncludeCppDeps = False - , GHC.Driver.Session.depIncludePkgDeps = False - , GHC.Driver.Session.depMakefile = "" - , GHC.Driver.Session.depSuffixes = [] - , GHC.Driver.Session.dirsToClean = error "dirsToClean" - , GHC.Driver.Session.dump_action = \_ _ _ _ _ _ -> pure () - , GHC.Driver.Session.dumpDir = Nothing - , GHC.Driver.Session.dumpFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.dumpPrefix = Nothing - , GHC.Driver.Session.dumpPrefixForce = Nothing - , GHC.Driver.Session.dylibInstallName = Nothing - , GHC.Driver.Session.dynHiSuf = "" - , GHC.Driver.Session.dynLibLoader = GHC.Driver.Session.Deployable - , GHC.Driver.Session.dynObjectSuf = "" - , GHC.Driver.Session.dynOutputFile = Nothing - , GHC.Driver.Session.enableTimeStats = False - , GHC.Driver.Session.extensionFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.extensions = [] - , GHC.Driver.Session.fatalWarningFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.fileSettings = initialFileSettings - , GHC.Driver.Session.filesToClean = error "filesToClean" - , GHC.Driver.Session.floatLamArgs = Nothing - , GHC.Driver.Session.flushErr = GHC.Driver.Session.defaultFlushErr - , GHC.Driver.Session.flushOut = GHC.Driver.Session.defaultFlushOut - , GHC.Driver.Session.frameworkPaths = [] - , GHC.Driver.Session.frontendPluginOpts = [] - , GHC.Driver.Session.generalFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.generatedDumps = error "generatedDumps" - , GHC.Driver.Session.ghcHeapSize = Nothing - , GHC.Driver.Session.ghciHistSize = 0 - , GHC.Driver.Session.ghciScripts = [] - , GHC.Driver.Session.ghcLink = GHC.Driver.Session.NoLink - , GHC.Driver.Session.ghcMode = GHC.Driver.Session.OneShot - , GHC.Driver.Session.ghcNameVersion = initialGhcNameVersion - , GHC.Driver.Session.ghcVersionFile = Nothing - , GHC.Driver.Session.haddockOptions = Nothing - , GHC.Driver.Session.hcSuf = "" - , GHC.Driver.Session.hiDir = Nothing - , GHC.Driver.Session.hieDir = Nothing - , GHC.Driver.Session.hieSuf = "" - , GHC.Driver.Session.historySize = 0 - , GHC.Driver.Session.hiSuf = "" - , GHC.Driver.Session.homeUnitId = GHC.Unit.Types.stringToUnitId "" - , GHC.Driver.Session.homeUnitInstanceOfId = Nothing - , GHC.Driver.Session.homeUnitInstantiations = [] - , GHC.Driver.Session.hooks = error "hooks" - , GHC.Driver.Session.hpcDir = "" - , GHC.Driver.Session.hscTarget = GHC.Driver.Session.HscNothing - , GHC.Driver.Session.ignorePackageFlags = [] - , GHC.Driver.Session.importPaths = [] - , GHC.Driver.Session.includePaths = initialIncludeSpecs - , GHC.Driver.Session.incoherentOnLoc = initialSrcSpan - , GHC.Driver.Session.initialUnique = 0 - , GHC.Driver.Session.inlineCheck = Nothing - , GHC.Driver.Session.interactivePrint = Nothing - , GHC.Driver.Session.language = Nothing - , GHC.Driver.Session.ldInputs = [] - , GHC.Driver.Session.liberateCaseThreshold = Nothing - , GHC.Driver.Session.libraryPaths = [] - , GHC.Driver.Session.liftLamsKnown = False - , GHC.Driver.Session.liftLamsNonRecArgs = Nothing - , GHC.Driver.Session.liftLamsRecArgs = Nothing - , GHC.Driver.Session.llvmConfig = initialLlvmConfig - , GHC.Driver.Session.log_action = \_ _ _ _ _ -> pure () - , GHC.Driver.Session.mainFunIs = Nothing - , GHC.Driver.Session.mainModIs = GHC.Unit.Types.mkModule - (GHC.Unit.Types.stringToUnit "") - (GHC.Unit.Module.Name.mkModuleName "") - , GHC.Driver.Session.maxErrors = Nothing - , GHC.Driver.Session.maxInlineAllocSize = 0 - , GHC.Driver.Session.maxInlineMemcpyInsns = 0 - , GHC.Driver.Session.maxInlineMemsetInsns = 0 - , GHC.Driver.Session.maxPmCheckModels = 0 - , GHC.Driver.Session.maxRefHoleFits = Nothing - , GHC.Driver.Session.maxRelevantBinds = Nothing - , GHC.Driver.Session.maxSimplIterations = 0 - , GHC.Driver.Session.maxUncoveredPatterns = 0 - , GHC.Driver.Session.maxValidHoleFits = Nothing - , GHC.Driver.Session.maxWorkerArgs = 0 - , GHC.Driver.Session.newDerivOnLoc = initialSrcSpan - , GHC.Driver.Session.nextTempSuffix = error "nextTempSuffix" - , GHC.Driver.Session.nextWrapperNum = error "nextWrapperNum" - , GHC.Driver.Session.objectDir = Nothing - , GHC.Driver.Session.objectSuf = "" - , GHC.Driver.Session.optLevel = 0 - , GHC.Driver.Session.outputFile = Nothing - , GHC.Driver.Session.outputHi = Nothing - , GHC.Driver.Session.overlapInstLoc = initialSrcSpan - , GHC.Driver.Session.packageDBFlags = [] - , GHC.Driver.Session.packageEnv = Nothing - , GHC.Driver.Session.packageFlags = [] - , GHC.Driver.Session.parMakeCount = Nothing - , GHC.Driver.Session.pkgTrustOnLoc = initialSrcSpan - , GHC.Driver.Session.platformConstants = initialPlatformConstants - , GHC.Driver.Session.platformMisc = initialPlatformMisc - , GHC.Driver.Session.pluginModNameOpts = [] - , GHC.Driver.Session.pluginModNames = [] - , GHC.Driver.Session.pluginPackageFlags = [] - , GHC.Driver.Session.pprCols = 80 - , GHC.Driver.Session.pprUserLength = 0 - , GHC.Driver.Session.profAuto = GHC.Driver.Session.NoProfAuto - , GHC.Driver.Session.rawSettings = [] - , GHC.Driver.Session.reductionDepth = GHC.Types.Basic.mkIntWithInf 0 - , GHC.Driver.Session.refLevelHoleFits = Nothing - , GHC.Driver.Session.reverseErrors = False - , GHC.Driver.Session.rtccInfo = error "rtccInfo" - , GHC.Driver.Session.rtldInfo = error "rtldInfo" - , GHC.Driver.Session.rtsOpts = Nothing - , GHC.Driver.Session.rtsOptsEnabled = GHC.Driver.Session.RtsOptsNone - , GHC.Driver.Session.rtsOptsSuggestions = False - , GHC.Driver.Session.ruleCheck = Nothing - , GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Ignore - , GHC.Driver.Session.safeInfer = False - , GHC.Driver.Session.safeInferred = False - , GHC.Driver.Session.simplPhases = 0 - , GHC.Driver.Session.simplTickFactor = 0 - , GHC.Driver.Session.solverIterations = GHC.Types.Basic.mkIntWithInf 0 - , GHC.Driver.Session.specConstrCount = Nothing - , GHC.Driver.Session.specConstrRecursive = 0 - , GHC.Driver.Session.specConstrThreshold = Nothing - , GHC.Driver.Session.splitInfo = Nothing - , GHC.Driver.Session.sseVersion = Nothing - , GHC.Driver.Session.staticPlugins = [] - , GHC.Driver.Session.strictnessBefore = [] - , GHC.Driver.Session.stubDir = Nothing - , GHC.Driver.Session.targetPlatform = initialTargetPlatform - , GHC.Driver.Session.thOnLoc = initialSrcSpan - , GHC.Driver.Session.toolSettings = initialToolSettings - , GHC.Driver.Session.trace_action = \_ _ _ a -> a - , GHC.Driver.Session.trustFlags = [] - , GHC.Driver.Session.trustworthyOnLoc = initialSrcSpan - , GHC.Driver.Session.ufCreationThreshold = 0 - , GHC.Driver.Session.ufDearOp = 0 - , GHC.Driver.Session.ufDictDiscount = 0 - , GHC.Driver.Session.ufFunAppDiscount = 0 - , GHC.Driver.Session.ufUseThreshold = 0 - , GHC.Driver.Session.ufVeryAggressive = False - , GHC.Driver.Session.uniqueIncrement = 0 - , GHC.Driver.Session.unitDatabases = Nothing - , GHC.Driver.Session.unitState = GHC.Unit.State.emptyUnitState - , GHC.Driver.Session.useColor = GHC.Utils.Misc.Never - , GHC.Driver.Session.useUnicode = False - , GHC.Driver.Session.verbosity = 0 - , GHC.Driver.Session.warningFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.warnSafeOnLoc = initialSrcSpan - , GHC.Driver.Session.warnUnsafeOnLoc = initialSrcSpan - , GHC.Driver.Session.ways = Set.empty +initialDynFlags = GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig + +initialSettings :: GHC.Driver.Session.Settings +initialSettings = GHC.Driver.Session.Settings + { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion + , GHC.Driver.Session.sFileSettings = initialFileSettings + , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform + , GHC.Driver.Session.sToolSettings = initialToolSettings + , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc + , GHC.Driver.Session.sPlatformConstants = initialPlatformConstants + , GHC.Driver.Session.sRawSettings = [] } initialFileSettings :: GHC.Driver.Session.FileSettings @@ -273,10 +99,17 @@ initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion , GHC.Driver.Session.ghcNameVersion_projectVersion = "" } -initialIncludeSpecs :: GHC.Driver.Session.IncludeSpecs -initialIncludeSpecs = GHC.Driver.Session.IncludeSpecs - { GHC.Driver.Session.includePathsGlobal = [] - , GHC.Driver.Session.includePathsQuote = [] +initialPlatformMisc :: GHC.Driver.Session.PlatformMisc +initialPlatformMisc = GHC.Driver.Session.PlatformMisc + { GHC.Driver.Session.platformMisc_ghcDebugged = False + , GHC.Driver.Session.platformMisc_ghcRTSWays = "" + , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False + , GHC.Driver.Session.platformMisc_ghcThreaded = False + , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False + , GHC.Driver.Session.platformMisc_ghcWithSMP = False + , GHC.Driver.Session.platformMisc_libFFI = False + , GHC.Driver.Session.platformMisc_llvmTarget = "" + , GHC.Driver.Session.platformMisc_targetPlatformString = "" } initialLlvmConfig :: GHC.Driver.Session.LlvmConfig @@ -424,23 +257,6 @@ initialPlatformMini = GHC.Settings.PlatformMini , GHC.Settings.platformMini_os = GHC.Platform.OSLinux } -initialPlatformMisc :: GHC.Driver.Session.PlatformMisc -initialPlatformMisc = GHC.Driver.Session.PlatformMisc - { GHC.Driver.Session.platformMisc_ghcDebugged = False - , GHC.Driver.Session.platformMisc_ghcRTSWays = "" - , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False - , GHC.Driver.Session.platformMisc_ghcThreaded = False - , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False - , GHC.Driver.Session.platformMisc_ghcWithSMP = False - , GHC.Driver.Session.platformMisc_libFFI = False - , GHC.Driver.Session.platformMisc_llvmTarget = "" - , GHC.Driver.Session.platformMisc_targetPlatformString = "" - } - -initialSrcSpan :: GHC.Types.SrcLoc.SrcSpan -initialSrcSpan = - GHC.Types.SrcLoc.UnhelpfulSpan GHC.Types.SrcLoc.UnhelpfulNoLocationInfo - initialTargetPlatform :: GHC.Settings.Platform initialTargetPlatform = GHC.Settings.Platform { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian -- 2.30.2 From 29814f919ec1886b2f8d1ce52ea6727a07782d71 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Tue, 11 Jan 2022 08:49:47 -0500 Subject: [PATCH 475/478] Version 0.14.0.1 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index c95544f..03c9d81 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: brittany -version: 0.14.0.0 +version: 0.14.0.1 synopsis: Haskell source code formatter description: See . -- 2.30.2 From 93a43bf28dc4cd781ae393748196789b5306f18c Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Thu, 13 Jan 2022 14:16:14 +0000 Subject: [PATCH 476/478] Revert "Remove `Language.Haskell.` from module names" This reverts commit 2fe1432631ac103284729c9afbbf0b0045228150. --- brittany.cabal | 60 +++++++++---------- source/executable/Main.hs | 2 +- .../{ => Language/Haskell}/Brittany.hs | 10 ++-- .../Haskell}/Brittany/Internal.hs | 36 +++++------ .../Haskell}/Brittany/Internal/Backend.hs | 16 ++--- .../Brittany/Internal/BackendUtils.hs | 12 ++-- .../Haskell}/Brittany/Internal/Config.hs | 12 ++-- .../Brittany/Internal/Config/Types.hs | 6 +- .../Internal/Config/Types/Instances.hs | 6 +- .../Brittany/Internal/ExactPrintUtils.hs | 10 ++-- .../Brittany/Internal/LayouterBasics.hs | 14 ++--- .../Brittany/Internal/Layouters/DataDecl.hs | 14 ++--- .../Brittany/Internal/Layouters/Decl.hs | 24 ++++---- .../Brittany/Internal/Layouters/Expr.hs | 22 +++---- .../Brittany/Internal/Layouters/Expr.hs-boot | 4 +- .../Brittany/Internal/Layouters/IE.hs | 10 ++-- .../Brittany/Internal/Layouters/Import.hs | 14 ++--- .../Brittany/Internal/Layouters/Module.hs | 16 ++--- .../Brittany/Internal/Layouters/Pattern.hs | 14 ++--- .../Brittany/Internal/Layouters/Stmt.hs | 18 +++--- .../Brittany/Internal/Layouters/Stmt.hs-boot | 4 +- .../Brittany/Internal/Layouters/Type.hs | 12 ++-- .../Haskell}/Brittany/Internal/Obfuscation.hs | 6 +- .../Haskell}/Brittany/Internal/ParseModule.hs | 2 +- .../Haskell}/Brittany/Internal/Prelude.hs | 2 +- .../Brittany/Internal/PreludeUtils.hs | 2 +- .../Brittany/Internal/Transformations/Alt.hs | 12 ++-- .../Internal/Transformations/Columns.hs | 6 +- .../Internal/Transformations/Floating.hs | 10 ++-- .../Internal/Transformations/Indent.hs | 6 +- .../Brittany/Internal/Transformations/Par.hs | 8 +-- .../Haskell}/Brittany/Internal/Types.hs | 6 +- .../Haskell}/Brittany/Internal/Utils.hs | 10 ++-- .../{ => Language/Haskell}/Brittany/Main.hs | 18 +++--- source/test-suite/Main.hs | 2 +- 35 files changed, 213 insertions(+), 213 deletions(-) rename source/library/{ => Language/Haskell}/Brittany.hs (63%) rename source/library/{ => Language/Haskell}/Brittany/Internal.hs (95%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Backend.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/BackendUtils.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Config.hs (97%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Config/Types.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Config/Types/Instances.hs (96%) rename source/library/{ => Language/Haskell}/Brittany/Internal/ExactPrintUtils.hs (96%) rename source/library/{ => Language/Haskell}/Brittany/Internal/LayouterBasics.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/DataDecl.hs (97%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Decl.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Expr.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Expr.hs-boot (67%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/IE.hs (96%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Import.hs (94%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Module.hs (94%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Pattern.hs (95%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Stmt.hs (87%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Stmt.hs-boot (50%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Layouters/Type.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Obfuscation.hs (93%) rename source/library/{ => Language/Haskell}/Brittany/Internal/ParseModule.hs (99%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Prelude.hs (98%) rename source/library/{ => Language/Haskell}/Brittany/Internal/PreludeUtils.hs (96%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Transformations/Alt.hs (99%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Transformations/Columns.hs (96%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Transformations/Floating.hs (97%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Transformations/Indent.hs (91%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Transformations/Par.hs (85%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Types.hs (99%) rename source/library/{ => Language/Haskell}/Brittany/Internal/Utils.hs (97%) rename source/library/{ => Language/Haskell}/Brittany/Main.hs (97%) diff --git a/brittany.cabal b/brittany.cabal index 03c9d81..7708fa1 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -101,36 +101,36 @@ library autogen-modules: Paths_brittany hs-source-dirs: source/library exposed-modules: - Brittany - Brittany.Internal - Brittany.Internal.Backend - Brittany.Internal.BackendUtils - Brittany.Internal.Config - Brittany.Internal.Config.Types - Brittany.Internal.Config.Types.Instances - Brittany.Internal.ExactPrintUtils - Brittany.Internal.LayouterBasics - Brittany.Internal.Layouters.DataDecl - Brittany.Internal.Layouters.Decl - Brittany.Internal.Layouters.Expr - Brittany.Internal.Layouters.IE - Brittany.Internal.Layouters.Import - Brittany.Internal.Layouters.Module - Brittany.Internal.Layouters.Pattern - Brittany.Internal.Layouters.Stmt - Brittany.Internal.Layouters.Type - Brittany.Internal.Obfuscation - Brittany.Internal.ParseModule - Brittany.Internal.Prelude - Brittany.Internal.PreludeUtils - Brittany.Internal.Transformations.Alt - Brittany.Internal.Transformations.Columns - Brittany.Internal.Transformations.Floating - Brittany.Internal.Transformations.Indent - Brittany.Internal.Transformations.Par - Brittany.Internal.Types - Brittany.Internal.Utils - Brittany.Main + Language.Haskell.Brittany + Language.Haskell.Brittany.Internal + Language.Haskell.Brittany.Internal.Backend + Language.Haskell.Brittany.Internal.BackendUtils + Language.Haskell.Brittany.Internal.Config + Language.Haskell.Brittany.Internal.Config.Types + Language.Haskell.Brittany.Internal.Config.Types.Instances + Language.Haskell.Brittany.Internal.ExactPrintUtils + Language.Haskell.Brittany.Internal.LayouterBasics + Language.Haskell.Brittany.Internal.Layouters.DataDecl + Language.Haskell.Brittany.Internal.Layouters.Decl + Language.Haskell.Brittany.Internal.Layouters.Expr + Language.Haskell.Brittany.Internal.Layouters.IE + Language.Haskell.Brittany.Internal.Layouters.Import + Language.Haskell.Brittany.Internal.Layouters.Module + Language.Haskell.Brittany.Internal.Layouters.Pattern + Language.Haskell.Brittany.Internal.Layouters.Stmt + Language.Haskell.Brittany.Internal.Layouters.Type + Language.Haskell.Brittany.Internal.Obfuscation + Language.Haskell.Brittany.Internal.ParseModule + Language.Haskell.Brittany.Internal.Prelude + Language.Haskell.Brittany.Internal.PreludeUtils + Language.Haskell.Brittany.Internal.Transformations.Alt + Language.Haskell.Brittany.Internal.Transformations.Columns + Language.Haskell.Brittany.Internal.Transformations.Floating + Language.Haskell.Brittany.Internal.Transformations.Indent + Language.Haskell.Brittany.Internal.Transformations.Par + Language.Haskell.Brittany.Internal.Types + Language.Haskell.Brittany.Internal.Utils + Language.Haskell.Brittany.Main Paths_brittany executable brittany diff --git a/source/executable/Main.hs b/source/executable/Main.hs index 6abfcca..7a5ae94 100644 --- a/source/executable/Main.hs +++ b/source/executable/Main.hs @@ -1,4 +1,4 @@ -import qualified Brittany.Main as BrittanyMain +import qualified Language.Haskell.Brittany.Main as BrittanyMain main :: IO () main = BrittanyMain.main diff --git a/source/library/Brittany.hs b/source/library/Language/Haskell/Brittany.hs similarity index 63% rename from source/library/Brittany.hs rename to source/library/Language/Haskell/Brittany.hs index d7630ba..a2726c8 100644 --- a/source/library/Brittany.hs +++ b/source/library/Language/Haskell/Brittany.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Brittany +module Language.Haskell.Brittany ( parsePrintModule , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled @@ -18,7 +18,7 @@ module Brittany , BrittanyError(..) ) where -import Brittany.Internal -import Brittany.Internal.Config -import Brittany.Internal.Config.Types -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs similarity index 95% rename from source/library/Brittany/Internal.hs rename to source/library/Language/Haskell/Brittany/Internal.hs index e73bcef..06cbb63 100644 --- a/source/library/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Brittany.Internal +module Language.Haskell.Brittany.Internal ( parsePrintModule , parsePrintModuleTests , pPrintModule @@ -36,23 +36,23 @@ import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List import GHC.Parser.Annotation (AnnKeywordId(..)) import GHC.Types.SrcLoc (SrcSpan) -import Brittany.Internal.Backend -import Brittany.Internal.BackendUtils -import Brittany.Internal.Config -import Brittany.Internal.Config.Types -import Brittany.Internal.ExactPrintUtils -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Layouters.Decl -import Brittany.Internal.Layouters.Module -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Transformations.Alt -import Brittany.Internal.Transformations.Columns -import Brittany.Internal.Transformations.Floating -import Brittany.Internal.Transformations.Indent -import Brittany.Internal.Transformations.Par -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Backend +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Transformations.Alt +import Language.Haskell.Brittany.Internal.Transformations.Columns +import Language.Haskell.Brittany.Internal.Transformations.Floating +import Language.Haskell.Brittany.Internal.Transformations.Indent +import Language.Haskell.Brittany.Internal.Transformations.Par +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified UI.Butcher.Monadic as Butcher diff --git a/source/library/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs similarity index 98% rename from source/library/Brittany/Internal/Backend.hs rename to source/library/Language/Haskell/Brittany/Internal/Backend.hs index 35fb3c2..55a3c97 100644 --- a/source/library/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -4,7 +4,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Brittany.Internal.Backend where +module Language.Haskell.Brittany.Internal.Backend where import qualified Control.Monad.Trans.State.Strict as StateS import qualified Data.Either as Either @@ -19,13 +19,13 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.OldList as List -import Brittany.Internal.BackendUtils -import Brittany.Internal.Config.Types -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types diff --git a/source/library/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs similarity index 98% rename from source/library/Brittany/Internal/BackendUtils.hs rename to source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index dbadef4..310ea56 100644 --- a/source/library/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.BackendUtils where +module Language.Haskell.Brittany.Internal.BackendUtils where import qualified Data.Data import qualified Data.Either @@ -12,11 +12,11 @@ import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder import GHC (Located) import qualified GHC.OldList as List -import Brittany.Internal.Config.Types -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint diff --git a/source/library/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs similarity index 97% rename from source/library/Brittany/Internal/Config.hs rename to source/library/Language/Haskell/Brittany/Internal/Config.hs index 0f62c26..040320b 100644 --- a/source/library/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Config where +module Language.Haskell.Brittany.Internal.Config where import qualified Data.Bool as Bool import qualified Data.ByteString as ByteString @@ -12,11 +12,11 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Semigroup as Semigroup import qualified Data.Yaml import qualified GHC.OldList as List -import Brittany.Internal.Config.Types -import Brittany.Internal.Config.Types.Instances () -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config.Types.Instances () +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Utils import qualified System.Console.CmdArgs.Explicit as CmdArgs import qualified System.Directory import qualified System.Directory as Directory diff --git a/source/library/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs similarity index 98% rename from source/library/Brittany/Internal/Config/Types.hs rename to source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index aed9f2c..0f0075a 100644 --- a/source/library/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -5,7 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -module Brittany.Internal.Config.Types where +module Language.Haskell.Brittany.Internal.Config.Types where import Data.CZipWith import Data.Coerce (Coercible, coerce) @@ -14,8 +14,8 @@ import qualified Data.Semigroup as Semigroup import Data.Semigroup (Last) import Data.Semigroup.Generic import GHC.Generics -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils () +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils () diff --git a/source/library/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs similarity index 96% rename from source/library/Brittany/Internal/Config/Types/Instances.hs rename to source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index ef7113b..c667038 100644 --- a/source/library/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -16,13 +16,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Config.Types.Instances where +module Language.Haskell.Brittany.Internal.Config.Types.Instances where import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson import Data.Yaml -import Brittany.Internal.Config.Types -import Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude diff --git a/source/library/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs similarity index 96% rename from source/library/Brittany/Internal/ExactPrintUtils.hs rename to source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 863c1fd..63d6b53 100644 --- a/source/library/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -5,7 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Brittany.Internal.ExactPrintUtils where +module Language.Haskell.Brittany.Internal.ExactPrintUtils where import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS @@ -23,10 +23,10 @@ import qualified GHC.Driver.CmdLine as GHC import GHC.Hs import qualified GHC.Types.SrcLoc as GHC import GHC.Types.SrcLoc (Located, SrcSpan) -import Brittany.Internal.Config.Types -import qualified Brittany.Internal.ParseModule as ParseModule -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Config.Types +import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified System.IO diff --git a/source/library/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs similarity index 98% rename from source/library/Brittany/Internal/LayouterBasics.hs rename to source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d4e883b..136468e 100644 --- a/source/library/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -4,7 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.LayouterBasics where +module Language.Haskell.Brittany.Internal.LayouterBasics where import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Writer.Strict as Writer @@ -24,12 +24,12 @@ import GHC.Types.Name (getOccString) import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader (RdrName(..)) import qualified GHC.Types.SrcLoc as GHC -import Brittany.Internal.Config.Types -import Brittany.Internal.ExactPrintUtils -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types diff --git a/source/library/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs similarity index 97% rename from source/library/Brittany/Internal/Layouters/DataDecl.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 8ed54ff..37f648e 100644 --- a/source/library/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.DataDecl where +module Language.Haskell.Brittany.Internal.Layouters.DataDecl where import qualified Data.Data import qualified Data.Semigroup as Semigroup @@ -10,12 +10,12 @@ import GHC (GenLocated(L), Located) import qualified GHC import GHC.Hs import qualified GHC.OldList as List -import Brittany.Internal.Config.Types -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Layouters.Type -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs similarity index 98% rename from source/library/Brittany/Internal/Layouters/Decl.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index fd55956..9e22b6e 100644 --- a/source/library/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Brittany.Internal.Layouters.Decl where +module Language.Haskell.Brittany.Internal.Layouters.Decl where import qualified Data.Data import qualified Data.Foldable @@ -23,17 +23,17 @@ import GHC.Types.Basic , RuleMatchInfo(..) ) import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) -import Brittany.Internal.Config.Types -import Brittany.Internal.ExactPrintUtils -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Layouters.DataDecl -import {-# SOURCE #-} Brittany.Internal.Layouters.Expr -import Brittany.Internal.Layouters.Pattern -import {-# SOURCE #-} Brittany.Internal.Layouters.Stmt -import Brittany.Internal.Layouters.Type -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.DataDecl +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint diff --git a/source/library/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs similarity index 98% rename from source/library/Brittany/Internal/Layouters/Expr.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 0b34383..138a748 100644 --- a/source/library/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.Expr where +module Language.Haskell.Brittany.Internal.Layouters.Expr where import qualified Data.Data import qualified Data.Semigroup as Semigroup @@ -14,16 +14,16 @@ import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic import GHC.Types.Name -import Brittany.Internal.Config.Types -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Layouters.Decl -import Brittany.Internal.Layouters.Pattern -import Brittany.Internal.Layouters.Stmt -import Brittany.Internal.Layouters.Type -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot similarity index 67% rename from source/library/Brittany/Internal/Layouters/Expr.hs-boot rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index bfe60e4..4f913c3 100644 --- a/source/library/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -1,9 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.Expr where +module Language.Haskell.Brittany.Internal.Layouters.Expr where import GHC.Hs -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs similarity index 96% rename from source/library/Brittany/Internal/Layouters/IE.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index d1da317..8684842 100644 --- a/source/library/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.IE where +module Language.Haskell.Brittany.Internal.Layouters.IE where import qualified Data.List.Extra import qualified Data.Text as Text @@ -16,10 +16,10 @@ import GHC ) import GHC.Hs import qualified GHC.OldList as List -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Prelude -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs similarity index 94% rename from source/library/Brittany/Internal/Layouters/Import.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 93e7d83..fc17cde 100644 --- a/source/library/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.Import where +module Language.Haskell.Brittany.Internal.Layouters.Import where import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text @@ -8,12 +8,12 @@ import GHC (GenLocated(L), Located, moduleNameString, unLoc) import GHC.Hs import GHC.Types.Basic import GHC.Unit.Types (IsBootInterface(..)) -import Brittany.Internal.Config.Types -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Layouters.IE -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs similarity index 94% rename from source/library/Brittany/Internal/Layouters/Module.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 2a6cdbb..8de45d7 100644 --- a/source/library/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.Module where +module Language.Haskell.Brittany.Internal.Layouters.Module where import qualified Data.Maybe import qualified Data.Semigroup as Semigroup @@ -9,13 +9,13 @@ import qualified Data.Text as Text import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) import GHC.Hs import qualified GHC.OldList as List -import Brittany.Internal.Config.Types -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Layouters.IE -import Brittany.Internal.Layouters.Import -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types import Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos(..), commentContents, deltaRow) diff --git a/source/library/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs similarity index 95% rename from source/library/Brittany/Internal/Layouters/Pattern.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 0d31ecb..773d993 100644 --- a/source/library/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.Pattern where +module Language.Haskell.Brittany.Internal.Layouters.Pattern where import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq @@ -10,12 +10,12 @@ import GHC (GenLocated(L), ol_val) import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic -import Brittany.Internal.LayouterBasics -import {-# SOURCE #-} Brittany.Internal.Layouters.Expr -import Brittany.Internal.Layouters.Type -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs similarity index 87% rename from source/library/Brittany/Internal/Layouters/Stmt.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 729e3ef..5ef19c7 100644 --- a/source/library/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -2,20 +2,20 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Brittany.Internal.Layouters.Stmt where +module Language.Haskell.Brittany.Internal.Layouters.Stmt where import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import GHC (GenLocated(L)) import GHC.Hs -import Brittany.Internal.Config.Types -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Layouters.Decl -import {-# SOURCE #-} Brittany.Internal.Layouters.Expr -import Brittany.Internal.Layouters.Pattern -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.Decl +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot similarity index 50% rename from source/library/Brittany/Internal/Layouters/Stmt.hs-boot rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 0c1cf13..6cfd5c8 100644 --- a/source/library/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -1,9 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.Stmt where +module Language.Haskell.Brittany.Internal.Layouters.Stmt where import GHC.Hs -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs similarity index 98% rename from source/library/Brittany/Internal/Layouters/Type.hs rename to source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index a19be50..1662ffb 100644 --- a/source/library/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Layouters.Type where +module Language.Haskell.Brittany.Internal.Layouters.Type where import qualified Data.Text as Text import GHC (AnnKeywordId(..), GenLocated(L)) @@ -9,11 +9,11 @@ import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic import GHC.Utils.Outputable (ftext, showSDocUnsafe) -import Brittany.Internal.LayouterBasics -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils (FirstLastView(..), splitFirstLast) diff --git a/source/library/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs similarity index 93% rename from source/library/Brittany/Internal/Obfuscation.hs rename to source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs index 6ec2320..c1bd60a 100644 --- a/source/library/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -1,14 +1,14 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Obfuscation where +module Language.Haskell.Brittany.Internal.Obfuscation where import Data.Char import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified GHC.OldList as List -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import System.Random diff --git a/source/library/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs similarity index 99% rename from source/library/Brittany/Internal/ParseModule.hs rename to source/library/Language/Haskell/Brittany/Internal/ParseModule.hs index 316ea6b..03f83a5 100644 --- a/source/library/Brittany/Internal/ParseModule.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-implicit-prelude #-} -module Brittany.Internal.ParseModule where +module Language.Haskell.Brittany.Internal.ParseModule where import qualified Control.Monad as Monad import qualified Control.Monad.IO.Class as IO diff --git a/source/library/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs similarity index 98% rename from source/library/Brittany/Internal/Prelude.hs rename to source/library/Language/Haskell/Brittany/Internal/Prelude.hs index a130166..8198533 100644 --- a/source/library/Brittany/Internal/Prelude.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,4 +1,4 @@ -module Brittany.Internal.Prelude +module Language.Haskell.Brittany.Internal.Prelude ( module E ) where diff --git a/source/library/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs similarity index 96% rename from source/library/Brittany/Internal/PreludeUtils.hs rename to source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs index 1a6f5e4..394a78d 100644 --- a/source/library/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Brittany.Internal.PreludeUtils where +module Language.Haskell.Brittany.Internal.PreludeUtils where import Control.Applicative import Control.DeepSeq (NFData, force) diff --git a/source/library/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs similarity index 99% rename from source/library/Brittany/Internal/Transformations/Alt.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 00a242e..5cca1ca 100644 --- a/source/library/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -module Brittany.Internal.Transformations.Alt where +module Language.Haskell.Brittany.Internal.Transformations.Alt where import qualified Control.Monad.Memo as Memo import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS @@ -16,11 +16,11 @@ import qualified Data.List.Extra import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified GHC.OldList as List -import Brittany.Internal.Config.Types -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs similarity index 96% rename from source/library/Brittany/Internal/Transformations/Columns.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index a43bd69..0d2231e 100644 --- a/source/library/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -1,12 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Transformations.Columns where +module Language.Haskell.Brittany.Internal.Transformations.Columns where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List -import Brittany.Internal.Prelude -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs similarity index 97% rename from source/library/Brittany/Internal/Transformations/Floating.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 37d0b43..919decf 100644 --- a/source/library/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -1,14 +1,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Transformations.Floating where +module Language.Haskell.Brittany.Internal.Transformations.Floating where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs similarity index 91% rename from source/library/Brittany/Internal/Transformations/Indent.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index da0b102..613c5f0 100644 --- a/source/library/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -1,12 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Transformations.Indent where +module Language.Haskell.Brittany.Internal.Transformations.Indent where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List -import Brittany.Internal.Prelude -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs similarity index 85% rename from source/library/Brittany/Internal/Transformations/Par.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs index dda3329..6fe374a 100644 --- a/source/library/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Internal.Transformations.Par where +module Language.Haskell.Brittany.Internal.Transformations.Par where -import Brittany.Internal.Prelude -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils diff --git a/source/library/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs similarity index 99% rename from source/library/Brittany/Internal/Types.hs rename to source/library/Language/Haskell/Brittany/Internal/Types.hs index d8b1f44..6a2c8af 100644 --- a/source/library/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -10,7 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -module Brittany.Internal.Types where +module Language.Haskell.Brittany.Internal.Types where import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data @@ -19,8 +19,8 @@ import qualified Data.Kind as Kind import qualified Data.Strict.Maybe as Strict import qualified Data.Text.Lazy.Builder as Text.Builder import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) -import Brittany.Internal.Config.Types -import Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint (AnnKey) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types diff --git a/source/library/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs similarity index 97% rename from source/library/Brittany/Internal/Utils.hs rename to source/library/Language/Haskell/Brittany/Internal/Utils.hs index 1210c98..b62028f 100644 --- a/source/library/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -5,7 +5,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Brittany.Internal.Utils where +module Language.Haskell.Brittany.Internal.Utils where import qualified Data.ByteString as B import qualified Data.Coerce @@ -22,10 +22,10 @@ import qualified GHC.OldList as List import GHC.Types.Name.Occurrence as OccName (occNameString) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC -import Brittany.Internal.Config.Types -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Text.PrettyPrint as PP diff --git a/source/library/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs similarity index 97% rename from source/library/Brittany/Main.hs rename to source/library/Language/Haskell/Brittany/Main.hs index fe25bf2..e599fc2 100644 --- a/source/library/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -module Brittany.Main where +module Language.Haskell.Brittany.Main where import Control.Monad (zipWithM) import qualified Control.Monad.Trans.Except as ExceptT @@ -20,14 +20,14 @@ import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) -import Brittany.Internal -import Brittany.Internal.Config -import Brittany.Internal.Config.Types -import Brittany.Internal.Obfuscation -import Brittany.Internal.Prelude -import Brittany.Internal.PreludeUtils -import Brittany.Internal.Types -import Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Obfuscation +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Paths_brittany import qualified System.Directory as Directory diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 7ff05a4..e48ec56 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -1,6 +1,6 @@ import qualified Control.Monad as Monad import qualified Data.List as List -import qualified Brittany.Main as Brittany +import qualified Language.Haskell.Brittany.Main as Brittany import qualified System.Directory as Directory import qualified System.FilePath as FilePath import qualified Test.Hspec as Hspec -- 2.30.2 From 0aa04af4eba499b81fdfb401d98414e7731583cc Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Thu, 13 Jan 2022 09:28:26 -0500 Subject: [PATCH 477/478] Version 0.14.0.2 --- brittany.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 7708fa1..ad87944 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: brittany -version: 0.14.0.1 +version: 0.14.0.2 synopsis: Haskell source code formatter description: See . -- 2.30.2 From 420eac889e337c1b30a239bf57ca6a9f9eb0790b Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 11 Nov 2022 09:52:57 -0600 Subject: [PATCH 478/478] Announce end of maintenance --- README.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/README.md b/README.md index 254c7a4..d03fb97 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,11 @@ # 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) + +:warning: +This project is effectively unmaintained! +I ([@tfausak](https://github.com/tfausak)) would recommend switching to another formatter. +At time of writing (2022-11-11), I would suggest [Ormolu](https://github.com/tweag/ormolu). +Or if you prefer some configuration, I would suggest [Fourmolu](https://github.com/fourmolu/fourmolu). + haskell source code formatter ![Output sample](https://github.com/lspitzner/brittany/raw/master/brittany-sample.gif) -- 2.30.2