diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -61,7 +61,7 @@ - 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 @@ -104,8 +104,8 @@ #### 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 diff --git a/brittany.cabal b/brittany.cabal --- 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 . @@ -101,36 +101,36 @@ 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 --- 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/Brittany.hs b/source/library/Brittany.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany + ( parsePrintModule + , staticDefaultConfig + , forwardOptionsSyntaxExtsEnabled + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig + , Config + , CConfig(..) + , CDebugConfig(..) + , CLayoutConfig(..) + , CErrorHandlingConfig(..) + , CForwardOptions(..) + , CPreProcessorConfig(..) + , BrittanyError(..) + ) where + +import Brittany.Internal +import Brittany.Internal.Config +import Brittany.Internal.Config.Types +import Brittany.Internal.Types diff --git a/source/library/Brittany/Internal.hs b/source/library/Brittany/Internal.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal.hs @@ -0,0 +1,684 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Brittany.Internal + ( parsePrintModule + , parsePrintModuleTests + , pPrintModule + , pPrintModuleAndCheck + -- re-export from utils: + , parseModule + , parseModuleFromString + , extractCommentConfigs + , getTopLevelDeclNameMap + ) where + +import Control.Monad.Trans.Except +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Char (isSpace) +import Data.HList.HList +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Yaml +import qualified GHC hiding (parseModule) +import GHC (GenLocated(L)) +import qualified GHC.Driver.Session as GHC +import GHC.Hs +import qualified GHC.LanguageExtensions.Type as GHC +import qualified GHC.OldList as List +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.SrcLoc (SrcSpan) +import 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 + + + +data InlineConfigTarget + = InlineConfigTargetModule + | InlineConfigTargetNextDecl -- really only next in module + | InlineConfigTargetNextBinding -- by name + | InlineConfigTargetBinding String + +extractCommentConfigs + :: ExactPrint.Anns + -> TopLevelDeclNameMap + -> Either (String, String) (CConfig Maybe, PerItemConfig) +extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do + let + commentLiness = + [ ( k + , [ x + | (ExactPrint.Comment x _ _, _) <- + (ExactPrint.annPriorComments ann + ++ ExactPrint.annFollowingComments ann + ) + ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] + ) + | (k, ann) <- Map.toList anns + ] + let + configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + (("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) + let + configParser = Butcher.addAlternatives + [ ( "commandline-config" + , \s -> "-" `isPrefixOf` dropWhile (== ' ') s + , cmdlineConfigParser + ) + , ( "yaml-config-document" + , \s -> "{" `isPrefixOf` dropWhile (== ' ') s + , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") + $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) + . either (const Nothing) Just + . Data.Yaml.decodeEither' + . Data.ByteString.Char8.pack + -- TODO: use some proper utf8 encoder instead? + ) + ] + parser = do -- we will (mis?)use butcher here to parse the inline config + -- line. + let + nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + Butcher.addCmd "-next-declaration" nextDecl + Butcher.addCmd "-Next-Declaration" nextDecl + Butcher.addCmd "-NEXT-DECLARATION" nextDecl + let + nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + Butcher.addCmd "-next-binding" nextBinding + Butcher.addCmd "-Next-Binding" nextBinding + Butcher.addCmd "-NEXT-BINDING" nextBinding + let + disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) + Butcher.addCmd "-disable-next-binding" disableNextBinding + Butcher.addCmd "-Disable-Next-Binding" disableNextBinding + Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding + let + disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) + Butcher.addCmd "-disable-next-declaration" disableNextDecl + Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl + Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + let + disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) + Butcher.addCmd "-disable" disableFormatting + Butcher.addCmd "@" $ do + -- Butcher.addCmd "module" $ do + -- conf <- configParser + -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) + Butcher.addNullCmd $ do + bindingName <- Butcher.addParamString "BINDING" mempty + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetModule, conf) + lineConfigss <- configLiness `forM` \(k, ss) -> do + r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of + Left err -> Left $ (err, s) + Right c -> Right $ c + pure (k, r) + + let + perModule = foldl' + (<>) + mempty + [ conf + | (_, lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf) <- lineConfigs + ] + let + perBinding = Map.fromListWith + (<>) + [ (n, conf) + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs + , n <- case target of + InlineConfigTargetBinding s -> [s] + InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> + [name] + _ -> [] + ] + let + perKey = Map.fromListWith + (<>) + [ (k, conf) + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs + , case target of + InlineConfigTargetNextDecl -> True + InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> + True + _ -> False + ] + + pure + $ ( perModule + , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } + ) + + +getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap +getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = + TopLevelDeclNameMap $ Map.fromList + [ (ExactPrint.mkAnnKey decl, name) + | decl <- decls + , (name : _) <- [getDeclBindingNames decl] + ] + + +-- | Exposes the transformation in an pseudo-pure fashion. The signature +-- contains `IO` due to the GHC API not exposing a pure parsing function, but +-- there should be no observable effects. +-- +-- Note that this function ignores/resets all config values regarding +-- debugging, i.e. it will never use `trace`/write to stderr. +-- +-- Note that the ghc parsing function used internally currently is wrapped in +-- `mask_`, so cannot be killed easily. If you don't control the input, you +-- may wish to put some proper upper bound on the input's size as a timeout +-- won't do. +parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) +parsePrintModule configWithDebugs inputText = runExceptT $ do + let + config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack + (anns, parsedSource, hasCPP) <- do + let + hackF s = + if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s + let + hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + parseResult <- lift $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform $ Text.unpack inputText) + case parseResult of + Left err -> throwE [ErrorInput err] + Right x -> pure x + (inlineConf, perItemConf) <- + either (throwE . (: []) . uncurry ErrorMacroConfig) pure + $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack + if disableFormatting + then do + return inputText + else do + (errsWarns, outputTextL) <- do + let + omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule moduleConfig perItemConf anns parsedSource + else lift + $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource + let + hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + pure $ if hackAroundIncludes + then + ( ews + , TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + ) + else (ews, outRaw) + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let + hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) + if hasErrors + then throwE $ errsWarns + else pure $ TextL.toStrict outputTextL + + + +-- BrittanyErrors can be non-fatal warnings, thus both are returned instead +-- of an Either. +-- This should be cleaned up once it is clear what kinds of errors really +-- can occur. +pPrintModule + :: Config + -> PerItemConfig + -> ExactPrint.Anns + -> GHC.ParsedSource + -> ([BrittanyError], TextL.Text) +pPrintModule conf inlineConf anns parsedModule = + let + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) + -- unless () $ do + -- + -- debugStrings `forM_` \s -> + -- trace s $ return () + +-- | Additionally checks that the output compiles again, appending an error +-- if it does not. +pPrintModuleAndCheck + :: Config + -> PerItemConfig + -> ExactPrint.Anns + -> GHC.ParsedSource + -> IO ([BrittanyError], TextL.Text) +pPrintModuleAndCheck conf inlineConf anns parsedModule = do + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let (errs, output) = pPrintModule conf inlineConf anns parsedModule + parseResult <- parseModuleFromString + ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let + errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] + return (errs', output) + + +-- used for testing mostly, currently. +-- TODO: use parsePrintModule instead and remove this function. +parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) +parsePrintModuleTests conf filename input = do + let inputStr = Text.unpack input + parseResult <- parseModuleFromString + (conf & _conf_forward & _options_ghc & runIdentity) + filename + (const . pure $ Right ()) + inputStr + case parseResult of + Left err -> return $ Left err + Right (anns, parsedModule, _) -> runExceptT $ do + (inlineConf, perItemConf) <- + case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x + let moduleConf = cZipWith fromOptionIdentity conf inlineConf + let + omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (errs, ltext) <- if omitCheck + then return $ pPrintModule moduleConf perItemConf anns parsedModule + else lift + $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule + if null errs + then pure $ TextL.toStrict $ ltext + else + let + errStrs = errs <&> \case + ErrorInput str -> str + ErrorUnusedComment str -> str + LayoutWarning str -> str + ErrorUnknownNode str _ -> str + ErrorMacroConfig str _ -> "when parsing inline config: " ++ str + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs + +-- this approach would for if there was a pure GHC.parseDynamicFilePragma. +-- Unfortunately that does not exist yet, so we cannot provide a nominally +-- pure interface. + +-- parsePrintModuleTests :: Text -> Either String Text +-- parsePrintModuleTests input = do +-- let dflags = GHC.unsafeGlobalDynFlags +-- let fakeFileName = "SomeTestFakeFileName.hs" +-- let pragmaInfo = GHC.getOptions +-- dflags +-- (GHC.stringToStringBuffer $ Text.unpack input) +-- fakeFileName +-- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo +-- let parseResult = ExactPrint.Parsers.parseWith +-- dflags1 +-- fakeFileName +-- GHC.parseModule +-- inputStr +-- case parseResult of +-- Left (_, s) -> Left $ "parsing error: " ++ s +-- Right (anns, parsedModule) -> do +-- let (out, errs) = runIdentity +-- $ runMultiRWSTNil +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns +-- $ ppModule parsedModule +-- if (not $ null errs) +-- then do +-- let errStrs = errs <&> \case +-- ErrorUnusedComment str -> str +-- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs +-- else return $ TextL.toStrict $ Text.Builder.toLazyText out + +toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a +toLocal conf anns m = do + (x, write) <- + lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m + MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) + pure x + +ppModule :: GenLocated SrcSpan HsModule -> PPM () +ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do + defaultAnns <- do + anns <- mAsk + let annKey = ExactPrint.mkAnnKey lmod + let annMap = Map.findWithDefault Map.empty annKey anns + let isEof = (== ExactPrint.AnnEofPos) + let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } + pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap + + post <- ppPreamble lmod + decls `forM_` \decl -> do + let declAnnKey = ExactPrint.mkAnnKey decl + let declBindingNames = getDeclBindingNames decl + inlineConf <- mAsk + let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf + let + mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk <&> \annMap -> + Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap + + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns + + config <- mAsk + + let + config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + + let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + toLocal config' filteredAnns $ do + bd <- if exactprintOnly + then briDocMToPPM $ briDocByExactNoComment decl + else do + (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl + mTell debugs + mTell errs + if null errs + then pure r + else briDocMToPPM $ briDocByExactNoComment decl + layoutBriDoc bd + + let + finalComments = filter + (fst .> \case + ExactPrint.AnnComment{} -> True + _ -> False + ) + post + post `forM_` \case + (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do + ppmMoveToExactLoc l + mTell $ Text.Builder.fromString cmStr + (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> + let + folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> + ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + _ -> return () + +getDeclBindingNames :: LHsDecl GhcPs -> [String] +getDeclBindingNames (L _ decl) = case decl of + SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) + ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] + _ -> [] + + +-- Prints the information associated with the module annotation +-- This includes the imports +ppPreamble + :: GenLocated SrcSpan HsModule + -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] +ppPreamble lmod@(L loc m@HsModule{}) = do + filteredAnns <- mAsk <&> \annMap -> + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap + -- Since ghc-exactprint adds annotations following (implicit) + -- modules to both HsModule and the elements in the module + -- this can cause duplication of comments. So strip + -- attached annotations that come after the module's where + -- from the module node + config <- mAsk + let + shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + + let + (filteredAnns', post) = + case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let + modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp + mAnn' = mAnn { ExactPrint.annsDP = pre } + filteredAnns'' = + Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns + in (filteredAnns'', post') + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' + + if shouldReformatPreamble + then toLocal config filteredAnns' $ withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + else + let emptyModule = L loc m { hsmodDecls = [] } + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + return post + +_sigHead :: Sig GhcPs -> String +_sigHead = \case + TypeSig _ names _ -> + "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) + _ -> "unknown sig" + +_bindHead :: HsBind GhcPs -> String +_bindHead = \case + FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) + PatBind _ _pat _ ([], []) -> "PatBind smth" + _ -> "unknown bind" + + + +layoutBriDoc :: BriDocNumbered -> PPMLocal () +layoutBriDoc briDoc = do + -- first step: transform the briDoc. + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + -- Note that briDoc is BriDocNumbered, but state type is BriDoc. + -- That's why the alt-transform looks a bit special here. + traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw + $ briDocToDoc + $ unwrapBriDocNumbered + $ briDoc + -- bridoc transformation: remove alts + transformAlts briDoc >>= mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyFloating .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf + "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating + -- bridoc transformation: par removal + mGet >>= transformSimplifyPar .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyColumns .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + -- bridoc transformation: indent + mGet >>= transformSimplifyIndent .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + + anns :: ExactPrint.Anns <- mAsk + + let + state = LayoutState + { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } + + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + + let + remainingComments = + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] + remainingComments + `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) + + return $ () diff --git a/source/library/Brittany/Internal/Backend.hs b/source/library/Brittany/Internal/Backend.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Backend.hs @@ -0,0 +1,732 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Brittany.Internal.Backend where + +import qualified Control.Monad.Trans.State.Strict as StateS +import qualified Data.Either as Either +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified GHC.OldList as List +import 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 + + + +type ColIndex = Int + +data ColumnSpacing + = ColumnSpacingLeaf Int + | ColumnSpacingRef Int Int + +type ColumnBlock a = [a] +type ColumnBlocks a = Seq [a] +type ColMap1 + = IntMapL.IntMap {- ColIndex -} + (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 + = IntMapL.IntMap {- ColIndex -} + (Float, ColumnBlock Int, ColumnBlocks Int) + -- (ratio of hasSpace, maximum, raw) + +data ColInfo + = ColInfoStart -- start value to begin the mapAccumL. + | ColInfoNo BriDoc + | ColInfo ColIndex ColSig [(Int, ColInfo)] + +instance Show ColInfo where + show ColInfoStart = "ColInfoStart" + show (ColInfoNo bd) = + "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") + show (ColInfo ind sig list) = + "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + +data ColBuildState = ColBuildState + { _cbs_map :: ColMap1 + , _cbs_index :: ColIndex + } + +type LayoutConstraints m + = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) + +layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () +layoutBriDocM = \case + BDEmpty -> do + return () -- can it be that simple + BDLit t -> do + layoutIndentRestorePostComment + layoutRemoveIndentLevelLinger + layoutWriteAppend t + BDSeq list -> do + list `forM_` layoutBriDocM + -- in this situation, there is nothing to do about cols. + -- i think this one does not happen anymore with the current simplifications. + -- BDCols cSig list | BDPar sameLine lines <- List.last list -> + -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines + BDCols _ list -> do + list `forM_` layoutBriDocM + BDSeparator -> do + layoutAddSepSpace + BDAddBaseY indent bd -> do + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ layoutBriDocM bd + BDBaseYPushCur bd -> do + layoutBaseYPushCur + layoutBriDocM bd + BDBaseYPop bd -> do + layoutBriDocM bd + layoutBaseYPop + BDIndentLevelPushCur bd -> do + layoutIndentLevelPushCur + layoutBriDocM bd + BDIndentLevelPop bd -> do + layoutBriDocM bd + layoutIndentLevelPop + BDEnsureIndent indent bd -> do + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteEnsureBlock + layoutBriDocM bd + BDPar indent sameLine indented -> do + layoutBriDocM sameLine + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteNewlineBlock + layoutBriDocM indented + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt : _) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd + BDExternal annKey subKeys shouldAddComment t -> do + let + tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines + anns :: ExactPrint.Anns <- mAsk + when shouldAddComment $ do + layoutWriteAppend + $ Text.pack + $ "{-" + ++ show (annKey, Map.lookup annKey anns) + ++ "-}" + zip [1 ..] tlines `forM_` \(i, l) -> do + layoutWriteAppend $ l + unless (i == tlineCount) layoutWriteNewlineBlock + do + state <- mGet + let filterF k _ = not $ k `Set.member` subKeys + mSet $ state + { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state + } + BDPlain t -> do + layoutWriteAppend t + BDAnnotationPrior annKey bd -> do + state <- mGet + let m = _lstate_comments state + let + moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey + mAnn <- do + let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annPriorComments = [] }) + annKey + m + } + return mAnn + case mAnn of + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction + Just priors -> do + -- layoutResetSepSpace + priors + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + case comment of + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) + -- ^ evil hack for CPP + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + moveToExactLocationAction + layoutBriDocM bd + BDAnnotationKW annKey keyword bd -> do + layoutBriDocM bd + mComments <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let + mToSpan = case mAnn of + Just anns | Maybe.isNothing keyword -> Just anns + Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> + Just annR + _ -> Nothing + case mToSpan of + Just anns -> do + let + (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annsDP = rest }) + annKey + m + } + return $ nonEmpty comments + _ -> return Nothing + case mComments of + Nothing -> pure () + Just comments -> do + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + -- evil hack for CPP: + case comment of + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDAnnotationRest annKey bd -> do + layoutBriDocM bd + annMay <- do + state <- mGet + let m = _lstate_comments state + pure $ Map.lookup annKey m + let mComments = nonEmpty . extractAllComments =<< annMay + let + semiCount = length + [ () + | Just ann <- [annMay] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- + mAsk + <&> _conf_layout + .> _lconfig_experimentalSemicolonNewlines + .> confUnpack + mModify $ \state -> state + { _lstate_comments = Map.adjust + (\ann -> ann + { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } + ) + annKey + (_lstate_comments state) + } + case mComments of + Nothing -> do + when shouldAddSemicolonNewlines $ do + [1 .. semiCount] `forM_` const layoutWriteNewline + Just comments -> do + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack comment + case comment of + ('#' : _) -> layoutMoveToCommentPos y (-999) 1 + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do + mDP <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let + relevant = + [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] + -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] + case relevant of + [] -> pure Nothing + (ExactPrint.Types.DP (y, x) : _) -> do + mSet state { _lstate_commentNewlines = 0 } + pure $ Just (y - _lstate_commentNewlines state, x) + case mDP of + Nothing -> pure () + Just (y, x) -> + -- we abuse this, as we probably will print the KW next, which is + -- _not_ a comment.. + layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 + layoutBriDocM bd + BDNonBottomSpacing _ bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd + BDDebug s bd -> do + mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" + layoutBriDocM bd + +briDocLineLength :: BriDoc -> Int +briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc + -- the state encodes whether a separator was already + -- appended at the current position. + where + rec = \case + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds + BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines ls@(_ : _) -> do + x <- StateS.get + return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd + +briDocIsMultiLine :: BriDoc -> Bool +briDocIsMultiLine briDoc = rec briDoc + where + rec :: BriDoc -> Bool + rec = \case + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t | [_] <- Text.lines t -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_] -> False + BDLines [] -> error "briDocIsMultiLine BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd + +-- In theory +-- ========= + +-- .. this algorithm works roughly in these steps: +-- +-- 1. For each line, get the (nested) column info, descending as far as +-- BDCols nodes go. The column info is a (rose) tree where the leafs +-- are arbitrary (non-BDCols) BriDocs. +-- 2. Walk through the lines and compare its column info with that of its +-- predecessor. If both are non-leafs and the column "signatures" align +-- (they don't align e.g. when they are totally different syntactical +-- structures or the number of children differs), mark these parts of +-- the two tree structures as connected and recurse to its children +-- (i.e. again comparing the children in this line with the children in +-- the previous line). +-- 3. What we now have is one tree per line, and connections between "same" +-- nodes between lines. These connection can span multiple lines. +-- We next look at spacing information. This is available at the leafs, +-- but in this step we aggregate _over connections_. At the top level, this +-- gives us one piece of data: How long would each line be, if we fully +-- aligned everything (kept all connections "active"). In contrast to +-- just taking the sum of all leafs for each tree, this line length includes +-- the spaces used for alignment. +-- 4. Treat those lines where alignment would result in overflowing of the +-- column limit. This "treatment" is currently configurable, and can e.g. +-- mean: +-- a) we stop alignment alltogether, +-- b) we remove alignment just from the overflowing lines, +-- c) we reduce the number of spaces inserted in overflowing lines using +-- some technique to make them not overflow, but without reducing the +-- space insertion to zero, +-- d) don't do anything +-- 5. Actually print the lines, walking over each tree and inserting spaces +-- according to the info and decisions gathered in the previous steps. +-- +-- Possible improvements +-- ===================== +-- +-- - If alignment is disabled for specific lines, the aggregated per-connection +-- info of those lines is still retained and not recalculated. This can +-- result in spaces being inserted to create alignment with a line that +-- would overflow and thus gets disabled entirely. +-- An better approach would be to repeat step 3 after marking overflowing +-- lines as such, and not include the overflowing spacings as references +-- for non-overflowing ones. In the simplest case one additional iteration +-- would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine +-- this and first remove alignment in the deepest parts of the tree for +-- overflowing lines, repeating and moving upwards until no lines are +-- anymore overflowing. +-- Further, it may make sense to break up connections when overflowing would +-- occur. +-- - It may also make sense to not filter all overflowing lines, but remove +-- them one-by-one and in each step recalculate the aggregated connection +-- spacing info. Because removing one overflowing line from the calculation +-- may very well cause another previously overflowing line to not overflow +-- any longer. +-- There is also a nasty optimization problem hiding in there (find the +-- minimal amount of alignment disabling that results in no overflows) +-- but that is overkill. +-- +-- (with both these improvements there would be quite some repetition between +-- steps 3 and 4, but it should be possible to ensure termination. Still, +-- performance might become an issue as such an approach is not necessarily +-- linear in bridoc size any more.) +-- +-- In practice +-- =========== +-- +-- .. the current implementation is somewhat sloppy. Steps 1 and 2 +-- are executed in one step, step 3 already applies one strategy that disables +-- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some +-- of the calculations one might expect to occur in step 3. Steps 4 and 5 +-- are executed in the same recursion, too. +-- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue +-- mentioned in the first "possible improvement". +alignColsLines :: LayoutConstraints m => [BriDoc] -> m () +alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do + -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) + curX <- do + state <- mGet + return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe + 0 + (_lstate_addSepSpace state) + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + alignBreak <- + mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack + case () of + _ -> do + -- tellDebugMess ("processedMap: " ++ show processedMap) + sequence_ + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos + <&> processInfo colMax processedMap + where + (colInfos, finalState) = + StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) + -- maxZipper :: [Int] -> [Int] -> [Int] + -- maxZipper [] ys = ys + -- maxZipper xs [] = xs + -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr + colAggregation :: [Int] -> Int + colAggregation [] = 0 -- this probably cannot happen the way we call + -- this function, because _cbs_map only ever + -- contains nonempty Seqs. + colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ] + where alignMax' = max 0 alignMax + + processedMap :: ColMap2 + processedMap = fix $ \result -> + _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + let + colss = colSpacingss <&> \spss -> case reverse spss of + [] -> [] + (xN : xR) -> + reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR + where + fLast (ColumnSpacingLeaf len) = len + fLast (ColumnSpacingRef len _) = len + fInit (ColumnSpacingLeaf len) = len + fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of + Nothing -> 0 + Just (_, maxs, _) -> sum maxs + maxCols = {-Foldable.foldl1 maxZipper-} + fmap colAggregation $ transpose $ Foldable.toList colss + (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + counter count l = if List.last posXs + List.last l <= colMax + then count + 1 + else count + ratio = fromIntegral (foldl counter (0 :: Int) colss) + / fromIntegral (length colss) + in (ratio, maxCols, colss) + + mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocs bds = mergeBriDocsW ColInfoStart bds + + mergeBriDocsW + :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd : bdr) = do + info <- mergeInfoBriDoc True lastInfo bd + infor <- mergeBriDocsW + -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) + (if shouldBreakAfter bd then ColInfoStart else info) + bdr + return $ info : infor + + -- even with alignBreak config flag, we don't stop aligning for certain + -- ColSigs - the ones with "False" below. The main reason is that + -- there are uses of BDCols where they provide the alignment of several + -- consecutive full larger code segments, for example ColOpPrefix. + -- Motivating example is + -- > foo + -- > $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -- > , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + -- > ] + -- > ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ] + -- If we break the alignment here, then all three lines for the first + -- list move left by one, which is horrible. We really don't want to + -- break whole-block alignments. + -- For list, listcomp, tuple and tuples the reasoning is much simpler: + -- alignment should not have much effect anyways, so i simply make the + -- choice here that enabling alignment is the safer route for preventing + -- potential glitches, and it should never have a negative effect. + -- For RecUpdate the argument is much less clear - it is mostly a + -- personal preference to not break alignment for those, even if + -- multiline. Really, this should be configurable.. (TODO) + shouldBreakAfter :: BriDoc -> Bool + shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp{} _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True + + mergeInfoBriDoc + :: Bool + -> ColInfo + -> BriDoc + -> StateS.StateT ColBuildState Identity ColInfo + mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = + \case + brdc@(BDCols colSig subDocs) + | infoSig == colSig && length subLengthsInfos == length subDocs -> do + let + isLastList = if lastFlag + then (== length subDocs) <$> [1 ..] + else repeat False + infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs + `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd + let curLengths = briDocLineLength <$> subDocs + let trueSpacings = getTrueSpacings (zip curLengths infos) + do -- update map + s <- StateS.get + let m = _cbs_map s + let (Just (_, spaces)) = IntMapS.lookup infoInd m + StateS.put s + { _cbs_map = IntMapS.insert + infoInd + (lastFlag, spaces Seq.|> trueSpacings) + m + } + return $ ColInfo infoInd colSig (zip curLengths infos) + | otherwise -> briDocToColInfo lastFlag brdc + brdc -> return $ ColInfoNo brdc + +briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo +briDocToColInfo lastFlag = \case + BDCols sig list -> withAlloc lastFlag $ \ind -> do + let + isLastList = + if lastFlag then (== length list) <$> [1 ..] else repeat False + subInfos <- zip isLastList list `forM` uncurry briDocToColInfo + let lengthInfos = zip (briDocLineLength <$> list) subInfos + let trueSpacings = getTrueSpacings lengthInfos + return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) + bd -> return $ ColInfoNo bd + +getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] +getTrueSpacings lengthInfos = lengthInfos <&> \case + (len, ColInfo i _ _) -> ColumnSpacingRef len i + (len, _) -> ColumnSpacingLeaf len + +withAlloc + :: Bool + -> ( ColIndex + -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) + ) + -> StateS.State ColBuildState ColInfo +withAlloc lastFlag f = do + cbs <- StateS.get + let ind = _cbs_index cbs + StateS.put $ cbs { _cbs_index = ind + 1 } + (space, info) <- f ind + StateS.get >>= \c -> StateS.put + $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } + return info + +processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () +processInfo maxSpace m = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ + do + colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack + curX <- do + state <- mGet + -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) + let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state + return $ case _lstate_curYOrAddNewline state of + Left i -> case _lstate_commentCol state of + Nothing -> spaceAdd + i + Just c -> c + Right{} -> spaceAdd + let colMax = min colMaxConf (curX + maxSpace) + -- tellDebugMess $ show curX + let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m + let + maxCols2 = list <&> \case + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l + let maxCols = zipWith max maxCols1 maxCols2 + let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + -- handle the cases that the vertical alignment leads to more than max + -- cols: + -- this is not a full fix, and we must correct individually in addition. + -- because: the (at least) line with the largest element in the last + -- column will always still overflow, because we just updated the column + -- sizes in such a way that it works _if_ we have sizes (*factor) + -- in each column. but in that line, in the last column, we will be + -- forced to occupy the full vertical space, not reduced by any factor. + let + fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (* factor) .> truncate + _ -> posXs + let + spacings = + zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs + -- tellDebugMess $ "ind = " ++ show ind + -- tellDebugMess $ "maxCols = " ++ show maxCols + -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs + -- tellDebugMess $ "list = " ++ show list + -- tellDebugMess $ "maxSpace = " ++ show maxSpace + let + alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. + then noAlignAct + else alignAct + case alignMode of + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeMajority limit | ratio >= limit -> animousAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct + +processInfoIgnore :: LayoutConstraints m => ColInfo -> m () +processInfoIgnore = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Brittany/Internal/BackendUtils.hs b/source/library/Brittany/Internal/BackendUtils.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/BackendUtils.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.BackendUtils where + +import qualified Data.Data +import qualified Data.Either +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (Located) +import qualified GHC.OldList as List +import 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 + + + +traceLocal :: (MonadMultiState LayoutState m) => a -> m () +traceLocal _ = return () + + +layoutWriteAppend + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Text + -> m () +layoutWriteAppend t = do + traceLocal ("layoutWriteAppend", t) + state <- mGet + case _lstate_curYOrAddNewline state of + Right i -> do + replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" + Left{} -> do + return () + let spaces = fromMaybe 0 $ _lstate_addSepSpace state + mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') + mTell $ Text.Builder.fromText $ t + mModify $ \s -> s + { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces + , _lstate_addSepSpace = Nothing + } + +layoutWriteAppendSpaces + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Int + -> m () +layoutWriteAppendSpaces i = do + traceLocal ("layoutWriteAppendSpaces", i) + unless (i == 0) $ do + state <- mGet + mSet $ state + { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state + } + +layoutWriteAppendMultiline + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => [Text] + -> m () +layoutWriteAppendMultiline ts = do + traceLocal ("layoutWriteAppendMultiline", ts) + case ts of + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. + (l : lr) -> do + layoutWriteAppend l + lr `forM_` \x -> do + layoutWriteNewline + layoutWriteAppend x + +-- adds a newline and adds spaces to reach the base column. +layoutWriteNewlineBlock + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => m () +layoutWriteNewlineBlock = do + traceLocal ("layoutWriteNewlineBlock") + state <- mGet + mSet $ state + { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + } + +-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) => Int -> m () +-- layoutMoveToIndentCol i = do +-- #if INSERTTRACES +-- tellDebugMessShow ("layoutMoveToIndentCol", i) +-- #endif +-- state <- mGet +-- mSet $ state +-- { _lstate_addSepSpace = Just +-- $ if isJust $ _lstate_addNewline state +-- then i +-- else _lstate_indLevelLinger state + i - _lstate_curY state +-- } + +layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () +layoutSetCommentCol = do + state <- mGet + let + col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state + traceLocal ("layoutSetCommentCol", col) + unless (Data.Maybe.isJust $ _lstate_commentCol state) + $ mSet state { _lstate_commentCol = Just col } + +-- This is also used to move to non-comments in a couple of places. Seems +-- to be harmless so far.. +layoutMoveToCommentPos + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Int + -> Int + -> Int + -> m () +layoutMoveToCommentPos y x commentLines = do + traceLocal ("layoutMoveToCommentPos", y, x, commentLines) + state <- mGet + mSet state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right{} -> Right y + , _lstate_addSepSpace = + Just $ if Data.Maybe.isJust (_lstate_commentCol state) + then case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else if y == 0 then x else _lstate_indLevelLinger state + x + , _lstate_commentCol = Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state + , _lstate_commentNewlines = + _lstate_commentNewlines state + y + commentLines - 1 + } + +-- | does _not_ add spaces to again reach the current base column. +layoutWriteNewline + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => m () +layoutWriteNewline = do + traceLocal ("layoutWriteNewline") + state <- mGet + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right (i + 1) + , _lstate_addSepSpace = Nothing + } + +_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () +_layoutResetCommentNewlines = do + mModify $ \state -> state { _lstate_commentNewlines = 0 } + +layoutWriteEnsureNewlineBlock + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => m () +layoutWriteEnsureNewlineBlock = do + traceLocal ("layoutWriteEnsureNewlineBlock") + state <- mGet + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right $ max 1 i + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing + } + +layoutWriteEnsureAbsoluteN + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Int + -> m () +layoutWriteEnsureAbsoluteN n = do + state <- mGet + let + diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c, _) -> n - c + (Nothing, Left i) -> n - i + (Nothing, Right{}) -> n + traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) + when (diff > 0) $ do + mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to + -- at least (Just 1), so we won't + -- overwrite any old value in any + -- bad way. + +layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m () +layoutBaseYPushInternal i = do + traceLocal ("layoutBaseYPushInternal", i) + mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } + +layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m () +layoutBaseYPopInternal = do + traceLocal ("layoutBaseYPopInternal") + mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } + +layoutIndentLevelPushInternal :: (MonadMultiState LayoutState m) => Int -> m () +layoutIndentLevelPushInternal i = do + traceLocal ("layoutIndentLevelPushInternal", i) + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } + +layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPopInternal = do + traceLocal ("layoutIndentLevelPopInternal") + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } + +layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () +layoutRemoveIndentLevelLinger = do + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } + +layoutWithAddBaseCol + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + ) + => m () + -> m () +layoutWithAddBaseCol m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + m + layoutBaseYPopInternal + +layoutWithAddBaseColBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + ) + => m () + -> m () +layoutWithAddBaseColBlock m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutBaseYPopInternal + +layoutWithAddBaseColNBlock + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Int + -> m () + -> m () +layoutWithAddBaseColNBlock amount m = do + traceLocal ("layoutWithAddBaseColNBlock", amount) + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutBaseYPopInternal + +layoutWriteEnsureBlock + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => m () +layoutWriteEnsureBlock = do + traceLocal ("layoutWriteEnsureBlock") + state <- mGet + let + diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of + (Nothing, Left i) -> lstate_baseY state - i + (Nothing, Right{}) -> lstate_baseY state + (Just sp, Left i) -> max sp (lstate_baseY state - i) + (Just sp, Right{}) -> max sp (lstate_baseY state) + -- when (diff>0) $ layoutWriteNewlineBlock + when (diff > 0) $ do + mSet $ state { _lstate_addSepSpace = Just $ diff } + +layoutWithAddBaseColN + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Int + -> m () + -> m () +layoutWithAddBaseColN amount m = do + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + m + layoutBaseYPopInternal + +layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () +layoutBaseYPushCur = do + traceLocal ("layoutBaseYPushCur") + state <- mGet + case _lstate_commentCol state of + Nothing -> + case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> layoutBaseYPushInternal (i + j) + (Left i, Nothing) -> layoutBaseYPushInternal i + (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state + Just cCol -> layoutBaseYPushInternal cCol + +layoutBaseYPop :: (MonadMultiState LayoutState m) => m () +layoutBaseYPop = do + traceLocal ("layoutBaseYPop") + layoutBaseYPopInternal + +layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPushCur = do + traceLocal ("layoutIndentLevelPushCur") + state <- mGet + let + y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> i + j + (Left i, Nothing) -> i + (Right{}, Just j) -> j + (Right{}, Nothing) -> 0 + layoutIndentLevelPushInternal y + +layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPop = do + traceLocal ("layoutIndentLevelPop") + layoutIndentLevelPopInternal + -- why are comment indentations relative to the previous indentation on + -- the first node of an additional indentation, and relative to the outer + -- indentation after the last node of some indented stuff? sure does not + -- make sense. + layoutRemoveIndentLevelLinger + +layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () +layoutAddSepSpace = do + state <- mGet + mSet $ state + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state + } + +-- TODO: when refactoring is complete, the other version of this method +-- can probably be removed. +moveToExactAnn + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => AnnKey + -> m () +moveToExactAnn annKey = do + traceLocal ("moveToExactAnn", annKey) + anns <- mAsk + case Map.lookup annKey anns of + Nothing -> return () + Just ann -> do + -- curY <- mGet <&> _lstate_curY + let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann + -- mModify $ \state -> state { _lstate_addNewline = Just x } + moveToY y + +moveToY :: MonadMultiState LayoutState m => Int -> m () +moveToY y = mModify $ \state -> + let + upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in + state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just + (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } +-- fixMoveToLineByIsNewline :: MonadMultiState +-- LayoutState m => Int -> m Int +-- fixMoveToLineByIsNewline x = do +-- newLineState <- mGet <&> _lstate_isNewline +-- return $ if newLineState == NewLineStateYes +-- then x-1 +-- else x + +ppmMoveToExactLoc + :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () +ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do + replicateM_ x $ mTell $ Text.Builder.fromString "\n" + replicateM_ y $ mTell $ Text.Builder.fromString " " + +-- TODO: update and use, or clean up. Currently dead code. +layoutWritePriorComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Located ast + -> m () +layoutWritePriorComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annPriorComments = [] }) + key + anns + } + return mAnn + case mAnn of + Nothing -> return () + Just priors -> do + unless (null priors) $ layoutSetCommentCol + priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> + do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment + +-- TODO: update and use, or clean up. Currently dead code. +-- this currently only extracs from the `annsDP` field of Annotations. +-- per documentation, this seems sufficient, as the +-- "..`annFollowingComments` are only added by AST transformations ..". +layoutWritePostComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Located ast + -> m () +layoutWritePostComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns + } + return mAnn + case mAnn of + Nothing -> return () + Just posts -> do + unless (null posts) $ layoutSetCommentCol + posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> + do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment + +layoutIndentRestorePostComment + :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) + => m () +layoutIndentRestorePostComment = do + state <- mGet + let mCommentCol = _lstate_commentCol state + let eCurYAddNL = _lstate_curYOrAddNewline state + mModify + $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } + case (mCommentCol, eCurYAddNL) of + (Just commentCol, Left{}) -> do + layoutWriteEnsureNewlineBlock + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe + 0 + (_lstate_addSepSpace state) + _ -> return () + +-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, +-- MonadMultiWriter Text.Builder.Builder m, +-- MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) +-- => Located ast -> m () +-- layoutWritePriorCommentsRestore x = do +-- layoutWritePriorComments x +-- layoutIndentRestorePostComment +-- +-- layoutWritePostCommentsRestore :: (Data.Data.Data ast, +-- MonadMultiWriter Text.Builder.Builder m, +-- MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) +-- => Located ast -> m () +-- layoutWritePostCommentsRestore x = do +-- layoutWritePostComments x +-- layoutIndentRestorePostComment diff --git a/source/library/Brittany/Internal/Config.hs b/source/library/Brittany/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Config.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Config where + +import qualified Data.Bool as Bool +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 +import Data.CZipWith +import Data.Coerce (coerce) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Semigroup as Semigroup +import qualified Data.Yaml +import qualified GHC.OldList as List +import 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 +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import UI.Butcher.Monadic + +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } +staticDefaultConfig :: Config +staticDefaultConfig = Config + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False + , _dconf_dump_bridoc_simpl_floating = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False + } + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) + , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_experimentalSemicolonNewlines = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _econf_omit_output_valid_check = coerce False + } + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort + , _ppconf_hackAroundIncludes = coerce False + } + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False + } + +forwardOptionsSyntaxExtsEnabled :: ForwardOptions +forwardOptionsSyntaxExtsEnabled = ForwardOptions + { _options_ghc = Identity + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] + } + +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } +cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) +cmdlineConfigParser = do + -- TODO: why does the default not trigger; ind never should be []!! + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") + + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + + return $ Config + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = mempty + } + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty + , _lconfig_experimentalSemicolonNewlines = mempty + -- , _lconfig_allowSinglelineRecord = mempty + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty + , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck + } + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + } + where + falseToNothing = Bool.bool Nothing (Just True) + wrapLast :: Maybe a -> Maybe (Semigroup.Last a) + wrapLast = fmap Semigroup.Last + optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Maybe (f a) + optionConcat = mconcat . fmap (pure . pure) + +-- configParser :: Parser Config +-- configParser = Config +-- <$> option (eitherReader $ maybe (Left "required !") Right . readMaybe) +-- (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level") +-- <*> (Bar +-- <$> switch (long "bara" <> help "bara help") +-- <*> switch (long "barb") +-- <*> flag 3 5 (long "barc") +-- ) +-- +-- configParserInfo :: ParserInfo Config +-- configParserInfo = ParserInfo +-- { infoParser = configParser +-- , infoFullDesc = True +-- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" +-- , infoHeader = return $ PP.text "brittany" +-- , infoFooter = empty +-- , infoFailureCode = (-55) +-- , infoIntersperse = True +-- } + + +-- | Reads a config from a file. If the file does not exist, returns +-- Nothing. If the file exists and parsing fails, prints to stderr and +-- aborts the MaybeT. Otherwise succeed via Just. +-- If the second parameter is True and the file does not exist, writes the +-- staticDefaultConfig to the file. +readConfig + :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe)) +readConfig path = do + -- TODO: probably should catch IOErrors and then omit the existence check. + exists <- liftIO $ System.Directory.doesFileExist path + if exists + then do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither' contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) + mzero + Right x -> return x + return $ Just fileConf + else return $ Nothing + +-- | Looks for a user-global config file and return its path. +-- If there is no global config in a system, one will be created. +userConfigPath :: IO System.IO.FilePath +userConfigPath = do + userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + let searchDirs = [userBritPathSimple, userBritPathXdg] + globalConfig <- Directory.findFileWith + Directory.doesFileExist + searchDirs + "config.yaml" + maybe (writeUserConfig userBritPathXdg) pure globalConfig + where + writeUserConfig dir = do + let createConfPath = dir FilePath. "config.yaml" + liftIO $ Directory.createDirectoryIfMissing True dir + writeDefaultConfig $ createConfPath + pure createConfPath + +-- | Searches for a local (per-project) brittany config starting from a given directory +findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) +findLocalConfigPath dir = do + let dirParts = FilePath.splitDirectories dir + -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] + let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) + Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" + +-- | Reads specified configs. +readConfigs + :: CConfig Maybe -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigs cmdlineConfig configPaths = do + configs <- readConfig `mapM` configPaths + let + merged = + Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + return $ cZipWith fromOptionIdentity staticDefaultConfig merged + +-- | Reads provided configs +-- but also applies the user default configuration (with lowest priority) +readConfigsWithUserConfig + :: CConfig Maybe -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigsWithUserConfig cmdlineConfig configPaths = do + defaultPath <- liftIO $ userConfigPath + readConfigs cmdlineConfig (configPaths ++ [defaultPath]) + +writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () +writeDefaultConfig path = + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Just . runIdentity) + staticDefaultConfig + +showConfigYaml :: Config -> String +showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap + (\(Identity x) -> Just x) diff --git a/source/library/Brittany/Internal/Config/Types.hs b/source/library/Brittany/Internal/Config/Types.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Config/Types.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module 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 Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils () + + + +confUnpack :: Coercible a b => Identity a -> b +confUnpack (Identity x) = coerce x + +data CDebugConfig f = DebugConfig + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + } + deriving Generic + +data CLayoutConfig f = LayoutConfig + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + , _lconfig_indentPolicy :: f (Last IndentPolicy) + , _lconfig_indentAmount :: f (Last Int) + , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + -- when creating zero-indentation + -- multi-line list literals. + , _lconfig_importColumn :: f (Last Int) + -- ^ for import statement layouting, column at which to align the + -- elements to be imported from a module. + -- It is expected that importAsColumn >= importCol. + , _lconfig_importAsColumn :: f (Last Int) + -- ^ for import statement layouting, column at which put the module's + -- "as" name (which also affects the positioning of the "as" keyword). + -- It is expected that importAsColumn >= importCol. + , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) + , _lconfig_alignmentLimit :: f (Last Int) + -- roughly speaking, this sets an upper bound to the number of spaces + -- inserted to create horizontal alignment. + -- More specifically, if 'xs' are the widths of the columns in some + -- alignment-block, then the block will be aligned with the width + -- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ]. + , _lconfig_alignmentBreakOnMultiline :: f (Last Bool) + -- stops alignment between items that are not layouted as a single line. + -- e.g. for single-line alignment, things remain unchanged: + -- do + -- short <- stuff + -- loooooooong <- stuff + -- but not in cases such as: + -- do + -- short <- some more stuff + -- that requires two lines + -- loooooooong <- stuff + , _lconfig_hangingTypeSignature :: f (Last Bool) + -- Do not put "::" in a new line, and use hanging indentation for the + -- signature, i.e.: + -- func :: SomeLongStuff + -- -> SomeLongStuff + -- instead of the usual + -- func + -- :: SomeLongStuff + -- -> SomeLongStuff + -- As usual for hanging indentation, the result will be + -- context-sensitive (in the function name). + , _lconfig_reformatModulePreamble :: f (Last Bool) + -- whether the module preamble/header (module keyword, name, export list, + -- import statements) are reformatted. If false, only the elements of the + -- module (everything past the "where") are reformatted. + , _lconfig_allowSingleLineExportList :: f (Last Bool) + -- if true, and it fits in a single line, and there are no comments in the + -- export list, the following layout will be used: + -- > module MyModule (abc, def) where + -- > [stuff] + -- otherwise, the multi-line version is used: + -- > module MyModule + -- > ( abc + -- > , def + -- > ) + -- > where + , _lconfig_allowHangingQuasiQuotes :: f (Last Bool) + -- if false, the layouter sees any splices as infinitely big and places + -- them accordingly (in newlines, most likely); This also influences + -- parent nodes. + -- if true, the layouter is free to start a quasi-quotation at the end + -- of a line. + -- + -- false: + -- > let + -- > body = + -- > [json| + -- > hello + -- > |] + -- + -- true: + -- > let body = [json| + -- > hello + -- > |] + , _lconfig_experimentalSemicolonNewlines :: f (Last Bool) + -- enables an experimental feature to turn semicolons in brace notation + -- into newlines when using layout: + -- + -- > do { a ;; b } + -- + -- turns into + -- > do + -- > a + -- > + -- > b + -- + -- The implementation for this is a bit hacky and not tested; it might + -- break output syntax or not work properly for every kind of brace. So + -- far I have considered `do` and `case-of`. + -- , _lconfig_allowSinglelineRecord :: f (Last Bool) + -- -- if true, layouts record data decls as a single line when possible, e.g. + -- -- > MyPoint { x :: Double, y :: Double } + -- -- if false, always use the multi-line layout + -- -- > MyPoint + -- -- > { x :: Double + -- -- > , y :: Double + -- -- > } + } + deriving Generic + +data CForwardOptions f = ForwardOptions + { _options_ghc :: f [String] + } + deriving Generic + +data CErrorHandlingConfig f = ErrorHandlingConfig + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + -- ^ Determines when to fall back on the exactprint'ed output when + -- syntactical constructs are encountered which are not yet handled by + -- brittany. + -- Note that the "risky" setting is risky because even with the check of + -- the syntactic validity of the brittany output, at least in theory there + -- may be cases where the output is syntactically/semantically valid but + -- has different semantics than the code pre-transformation. + , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) + } + deriving Generic + +data CPreProcessorConfig f = PreProcessorConfig + { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) + , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) + } + deriving Generic + +data CConfig f = Config + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f + , _conf_errorHandling :: CErrorHandlingConfig f + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f + , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + -- ^ this field is somewhat of a duplicate of the one in DebugConfig. + -- It is used for per-declaration disabling by the inline config + -- implementation. Could have re-used the existing field, but felt risky + -- to use a "debug" labeled field for non-debug functionality. + , _conf_disable_formatting :: f (Semigroup.Last Bool) + -- ^ Used for inline config that disables brittany entirely for this + -- module. Useful for wildcard application + -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something + -- in that direction). + , _conf_obfuscate :: f (Semigroup.Last Bool) + } + deriving Generic + +type DebugConfig = CDebugConfig Identity +type LayoutConfig = CLayoutConfig Identity +type ForwardOptions = CForwardOptions Identity +type ErrorHandlingConfig = CErrorHandlingConfig Identity +type Config = CConfig Identity + +-- i wonder if any Show1 stuff could be leveraged. +deriving instance Show (CDebugConfig Identity) +deriving instance Show (CLayoutConfig Identity) +deriving instance Show (CErrorHandlingConfig Identity) +deriving instance Show (CForwardOptions Identity) +deriving instance Show (CPreProcessorConfig Identity) +deriving instance Show (CConfig Identity) + +deriving instance Show (CDebugConfig Maybe) +deriving instance Show (CLayoutConfig Maybe) +deriving instance Show (CErrorHandlingConfig Maybe) +deriving instance Show (CForwardOptions Maybe) +deriving instance Show (CPreProcessorConfig Maybe) +deriving instance Show (CConfig Maybe) + +deriving instance Data (CDebugConfig Identity) +deriving instance Data (CLayoutConfig Identity) +deriving instance Data (CErrorHandlingConfig Identity) +deriving instance Data (CForwardOptions Identity) +deriving instance Data (CPreProcessorConfig Identity) +deriving instance Data (CConfig Identity) + +deriving instance Data (CDebugConfig Maybe) +deriving instance Data (CLayoutConfig Maybe) +deriving instance Data (CErrorHandlingConfig Maybe) +deriving instance Data (CForwardOptions Maybe) +deriving instance Data (CPreProcessorConfig Maybe) +deriving instance Data (CConfig Maybe) + +instance Semigroup.Semigroup (CDebugConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CLayoutConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CForwardOptions Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CConfig Maybe) where + (<>) = gmappend + +instance Semigroup.Semigroup (CDebugConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CLayoutConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CForwardOptions Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CPreProcessorConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CConfig Identity) where + (<>) = gmappend + +instance Monoid (CDebugConfig Maybe) where + mempty = gmempty +instance Monoid (CLayoutConfig Maybe) where + mempty = gmempty +instance Monoid (CErrorHandlingConfig Maybe) where + mempty = gmempty +instance Monoid (CForwardOptions Maybe) where + mempty = gmempty +instance Monoid (CPreProcessorConfig Maybe) where + mempty = gmempty +instance Monoid (CConfig Maybe) where + mempty = gmempty + + +data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more + -- than old indentation + amount + | IndentPolicyFree -- can create new indentations whereever + | IndentPolicyMultiple -- can create indentations only + -- at any n * amount. + deriving (Eq, Show, Generic, Data) + +data AltChooser = AltChooserSimpleQuick -- always choose last alternative. + -- leads to tons of sparsely filled + -- lines. + | AltChooserShallowBest -- choose the first matching alternative + -- using the simplest spacing + -- information for the children. + | AltChooserBoundedSearch Int + -- choose the first matching alternative + -- using a bounded list of recursive + -- options having sufficient space. + deriving (Show, Generic, Data) + +data ColumnAlignMode + = ColumnAlignModeDisabled + -- ^ Make no column alignments whatsoever + | ColumnAlignModeUnanimously + -- ^ Make column alignments only if it does not cause overflow for any of + -- the affected lines. + | ColumnAlignModeMajority Float + -- ^ If at least (ratio::Float) of the aligned elements have sufficient + -- space for the alignment, act like ColumnAlignModeAnimously; otherwise + -- act like ColumnAlignModeDisabled. + | ColumnAlignModeAnimouslyScale Int + -- ^ Scale back columns to some degree if their sum leads to overflow. + -- This is done in a linear fashion. + -- The Int specifies additional columns to be added to column maximum for + -- scaling calculation purposes. + | ColumnAlignModeAnimously + -- ^ Decide on a case-by-case basis if alignment would cause overflow. + -- If it does, cancel all alignments for this (nested) column description. + -- ColumnAlignModeAnimouslySome -- potentially to implement + | ColumnAlignModeAlways + -- ^ Always respect column alignments, even if it makes stuff overflow. + deriving (Show, Generic, Data) + +data CPPMode = CPPModeAbort -- abort program on seeing -XCPP + | CPPModeWarn -- warn about CPP and non-roundtripping in its + -- presence. + | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is + -- file.) + deriving (Show, Generic, Data) + +data ExactPrintFallbackMode + = ExactPrintFallbackModeNever -- never fall back on exactprinting + | ExactPrintFallbackModeInline -- fall back only if there are no newlines in + -- the exactprint'ed output. + | ExactPrintFallbackModeRisky -- fall back even in the presence of newlines. + -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF + -- A PROGRAM BY TRANSFORMING IT. + deriving (Show, Generic, Data) + +deriveCZipWith ''CDebugConfig +deriveCZipWith ''CLayoutConfig +deriveCZipWith ''CErrorHandlingConfig +deriveCZipWith ''CForwardOptions +deriveCZipWith ''CPreProcessorConfig +deriveCZipWith ''CConfig + +instance CFunctor CDebugConfig +instance CFunctor CLayoutConfig +instance CFunctor CErrorHandlingConfig +instance CFunctor CForwardOptions +instance CFunctor CPreProcessorConfig +instance CFunctor CConfig diff --git a/source/library/Brittany/Internal/Config/Types/Instances.hs b/source/library/Brittany/Internal/Config/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Config/Types/Instances.hs @@ -0,0 +1,131 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- These optimizations are disabled to improve compile times (and compilation +-- memory usage). When we do not disable them, the CI servers take more than +-- 10 minutes to compile this module alone. +-- Having looked into aeson and how the instances are written, I still do +-- not understand what makes GHC choke so much here. The size of the raw +-- expressions below looks fairly negligible, so there must be some expansion +-- due to inlining going on. But even disabling INLINE pragmas in aeson did +-- not seem to change anything. +-- Nonetheless, this solution works and has no downsides because the +-- instances defined here are not in any way performance-critical. +{-# OPTIONS_GHC -fno-pre-inlining #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fignore-interface-pragmas #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module 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 + + + +aesonDecodeOptionsBrittany :: Aeson.Options +aesonDecodeOptionsBrittany = Aeson.defaultOptions + { Aeson.omitNothingFields = True + , Aeson.fieldLabelModifier = dropWhile (== '_') + } + +instance FromJSON (CDebugConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CDebugConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON IndentPolicy where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON IndentPolicy where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON AltChooser where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON AltChooser where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON ColumnAlignMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON ColumnAlignMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON CPPMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON CPPMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON ExactPrintFallbackMode where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON ExactPrintFallbackMode where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany + +instance FromJSON (CLayoutConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CLayoutConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CErrorHandlingConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CErrorHandlingConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CForwardOptions Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CForwardOptions Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance FromJSON (CPreProcessorConfig Maybe) where + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany + +instance ToJSON (CPreProcessorConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +instance ToJSON (CConfig Maybe) where + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany + +-- This custom instance ensures the "omitNothingFields" behaviour not only for +-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid +-- config file content. +instance FromJSON (CConfig Maybe) where + parseJSON (Object v) = + Config + <$> v + .:? Key.fromString "conf_version" + <*> v + .:?= Key.fromString "conf_debug" + <*> v + .:?= Key.fromString "conf_layout" + <*> v + .:?= Key.fromString "conf_errorHandling" + <*> v + .:?= Key.fromString "conf_forward" + <*> v + .:?= Key.fromString "conf_preprocessor" + <*> v + .:? Key.fromString "conf_roundtrip_exactprint_only" + <*> v + .:? Key.fromString "conf_disable_formatting" + <*> v + .:? Key.fromString "conf_obfuscate" + parseJSON invalid = Aeson.typeMismatch "Config" invalid + +-- Pretends that the value is {} when the key is not present. +(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a +o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure diff --git a/source/library/Brittany/Internal/ExactPrintUtils.hs b/source/library/Brittany/Internal/ExactPrintUtils.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/ExactPrintUtils.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Brittany.Internal.ExactPrintUtils where + +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.Data +import qualified Data.Foldable as Foldable +import qualified Data.Generics as SYB +import Data.HList.HList +import qualified Data.Map as Map +import qualified Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import GHC (GenLocated(L)) +import qualified GHC hiding (parseModule) +import qualified GHC.Driver.CmdLine as GHC +import GHC.Hs +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.SrcLoc (Located, SrcSpan) +import 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 + + + +parseModule + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModule args fp dynCheck = do + str <- System.IO.readFile fp + parseModuleFromString args fp dynCheck str + +parseModuleFromString + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> String + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModuleFromString = ParseModule.parseModule + + +commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () +commentAnnFixTransformGlob ast = do + let + extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` (\l@(L span _) -> + Seq.singleton (span, ExactPrint.mkAnnKey l) + ) + let nodes = SYB.everything (<>) extract ast + let + annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (const id) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes + ] + nodes `forM_` (snd .> processComs annsMap) + where + processComs annsMap annKey1 = do + mAnn <- State.Class.gets fst <&> Map.lookup annKey1 + mAnn `forM_` \ann1 -> do + let + priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 + let + processCom + :: (ExactPrint.Comment, ExactPrint.DeltaPos) + -> ExactPrint.TransformT Identity Bool + processCom comPair@(com, _) = + case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of + comLoc -> case Map.lookupLE comLoc annsMap of + Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of + (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> + move $> False + (x, y) | x == y -> move $> False + _ -> return True + where + ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 + ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 + move = ExactPrint.modifyAnnsT $ \anns -> + let + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2' = ann2 + { ExactPrint.annFollowingComments = + ExactPrint.annFollowingComments ann2 ++ [comPair] + } + in Map.insert annKey2 ann2' anns + _ -> return True -- retain comment at current node. + priors' <- filterM processCom priors + follows' <- filterM processCom follows + assocs' <- flip filterM assocs $ \case + (ExactPrint.AnnComment com, dp) -> processCom (com, dp) + _ -> return True + let + ann1' = ann1 + { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } + ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns + + +-- TODO: this is unused by now, but it contains one detail that +-- commentAnnFixTransformGlob does not include: Moving of comments for +-- "RecordUpd"s. +-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransform modul = SYB.everything (>>) genF modul +-- where +-- genF :: Data.Data.Data a => a -> ExactPrint.Transform () +-- genF = (\_ -> return ()) `SYB.extQ` exprF +-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () +-- exprF lexpr@(L _ expr) = case expr of +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #else +-- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- RecordUpd _ _e fs@(_:_) -> +-- #else +-- RecordUpd _e fs@(_:_) _cons _ _ _ -> +-- #endif +-- moveTrailingComments lexpr (List.last fs) +-- _ -> return () + +-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransform modul = SYB.everything (>>) genF modul +-- where +-- genF :: Data.Data.Data a => a -> ExactPrint.Transform () +-- genF = (\_ -> return ()) `SYB.extQ` exprF +-- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () +-- exprF lexpr@(L _ expr) = case expr of +-- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> +-- moveTrailingComments lexpr (List.last fs) +-- RecordUpd _ _e fs@(_:_) -> +-- moveTrailingComments lexpr (List.last fs) +-- _ -> return () + +-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) +-- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () +-- moveTrailingComments astFrom astTo = do +-- let +-- k1 = ExactPrint.mkAnnKey astFrom +-- k2 = ExactPrint.mkAnnKey astTo +-- moveComments ans = ans' +-- where +-- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans +-- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans +-- cs1f = ExactPrint.annFollowingComments an1 +-- cs2f = ExactPrint.annFollowingComments an2 +-- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) +-- $ \case +-- (ExactPrint.AnnComment com, dp) -> Left (com, dp) +-- x -> Right x +-- an1' = an1 +-- { ExactPrint.annsDP = nonComments +-- , ExactPrint.annFollowingComments = [] +-- } +-- an2' = an2 +-- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments +-- } +-- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans + +-- ExactPrint.modifyAnnsT moveComments + +-- | split a set of annotations in a module into a map from top-level module +-- elements to the relevant annotations. Avoids quadratic behaviour a trivial +-- implementation would have. +extractToplevelAnns + :: Located HsModule + -> ExactPrint.Anns + -> Map ExactPrint.AnnKey ExactPrint.Anns +extractToplevelAnns lmod anns = output + where + (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod + declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap1 = Map.unions $ ldecls <&> \ldecl -> + Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) + declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap2 = + Map.fromList + $ [ (captured, declMap1 Map.! k) + | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns + ] + declMap = declMap1 `Map.union` declMap2 + modKey = ExactPrint.mkAnnKey lmod + output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + +groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) +groupMap f = Map.foldlWithKey' + (\m k a -> Map.alter (insert k a) (f k a) m) + Map.empty + where + insert k a Nothing = Just (Map.singleton k a) + insert k a (Just m) = Just (Map.insert k a m) + +foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey +foldedAnnKeys ast = SYB.everything + Set.union + (\x -> maybe + Set.empty + Set.singleton + [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x + | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) + , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x + ] + -- for some reason, ghc-8.8 has forgotten how to infer the type of l, + -- even though it is passed to mkAnnKey above, which only accepts + -- SrcSpan. + ) + ast + where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) + + +withTransformedAnns + :: Data ast + => ast + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a +withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case + readers@(conf :+: anns :+: HNil) -> do + -- TODO: implement `local` for MultiReader/MultiRWS + MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) + x <- m + MultiRWSS.mPutRawR readers + pure x + where + f anns = + let + ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced + + +warnExtractorCompat :: GHC.Warn -> String +warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/source/library/Brittany/Internal/LayouterBasics.hs b/source/library/Brittany/Internal/LayouterBasics.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/LayouterBasics.hs @@ -0,0 +1,781 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.LayouterBasics where + +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Writer.Strict as Writer +import qualified Data.Char as Char +import Data.Data +import qualified Data.Map as Map +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import DataTreePrint +import GHC (GenLocated(L), Located, moduleName, moduleNameString) +import qualified GHC.OldList as List +import GHC.Parser.Annotation (AnnKeywordId(..)) +import GHC.Types.Name (getOccString) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Reader (RdrName(..)) +import qualified GHC.Types.SrcLoc as GHC +import 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 +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils + + + +processDefault + :: ( ExactPrint.Annotate.Annotate ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiReader ExactPrint.Types.Anns m + ) + => Located ast + -> m () +processDefault x = do + anns <- mAsk + let str = ExactPrint.exactPrint x anns + -- this hack is here so our print-empty-module trick does not add + -- a newline at the start if there actually is no module header / imports + -- / anything. + -- TODO: instead the appropriate annotation could be removed when "cleaning" + -- the module (header). This would remove the need for this hack! + case str of + "\n" -> return () + _ -> mTell $ Text.Builder.fromString str + +-- | Use ExactPrint's output for this node; add a newly generated inline comment +-- at insertion position (meant to point out to the user that this node is +-- not handled by brittany yet). Useful when starting implementing new +-- syntactic constructs when children are not handled yet. +briDocByExact + :: (ExactPrint.Annotate.Annotate ast) + => Located ast + -> ToBriDocM BriDocNumbered +briDocByExact ast = do + anns <- mAsk + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + docExt ast anns True + +-- | Use ExactPrint's output for this node. +-- Consider that for multi-line input, the indentation of the code produced +-- by ExactPrint might be different, and even incompatible with the indentation +-- of its surroundings as layouted by brittany. But there are safe uses of +-- this, e.g. for any top-level declarations. +briDocByExactNoComment + :: (ExactPrint.Annotate.Annotate ast) + => Located ast + -> ToBriDocM BriDocNumbered +briDocByExactNoComment ast = do + anns <- mAsk + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + docExt ast anns False + +-- | Use ExactPrint's output for this node, presuming that this output does +-- not contain any newlines. If this property is not met, the semantics +-- depend on the @econf_AllowRiskyExactPrintUse@ config flag. +briDocByExactInlineOnly + :: (ExactPrint.Annotate.Annotate ast) + => String + -> Located ast + -> ToBriDocM BriDocNumbered +briDocByExactInlineOnly infoStr ast = do + anns <- mAsk + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns + fallbackMode <- + mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack + let + exactPrintNode t = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + t + let + errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + case (fallbackMode, Text.lines exactPrinted) of + (ExactPrintFallbackModeNever, _) -> errorAction + (_, [t]) -> exactPrintNode + (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) + (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted + _ -> errorAction + +rdrNameToText :: RdrName -> Text +-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr +rdrNameToText (Unqual occname) = Text.pack $ occNameString occname +rdrNameToText (Qual mname occname) = + Text.pack $ moduleNameString mname ++ "." ++ occNameString occname +rdrNameToText (Orig modul occname) = + Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname +rdrNameToText (Exact name) = Text.pack $ getOccString name + +lrdrNameToText :: GenLocated l RdrName -> Text +lrdrNameToText (L _ n) = rdrNameToText n + +lrdrNameToTextAnnGen + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => (Text -> Text) + -> Located RdrName + -> m Text +lrdrNameToTextAnnGen f ast@(L _ n) = do + anns <- mAsk + let t = f $ rdrNameToText n + let + hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False + -- TODO: in general: we should _always_ process all annotaiton stuff here. + -- whatever we don't probably should have had some effect on the + -- output. in such cases, resorting to byExact is probably the safe + -- choice. + return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> t + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + _ | any (hasUni AnnCommaTuple) aks -> t + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t + +lrdrNameToTextAnn + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => Located RdrName + -> m Text +lrdrNameToTextAnn = lrdrNameToTextAnnGen id + +lrdrNameToTextAnnTypeEqualityIsSpecial + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => Located RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecial ast = do + let + f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + lrdrNameToTextAnnGen f ast + +-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects +-- the annotations for a (parent) node for a tick to be added to the +-- literal. +-- Excessively long name to reflect on us having to work around such +-- excessively obscure special cases in the exactprint API. +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick + :: ( Data ast + , MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => Located ast + -> Located RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do + hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote + x <- lrdrNameToTextAnn ast2 + let + lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + return $ if hasQuote then Text.cons '\'' lit else lit + +askIndent :: (MonadMultiReader Config m) => m Int +askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk + + +extractAllComments + :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +extractAllComments ann = + ExactPrint.annPriorComments ann ++ extractRestComments ann + +extractRestComments + :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +extractRestComments ann = + ExactPrint.annFollowingComments ann + ++ (ExactPrint.annsDP ann >>= \case + (ExactPrint.AnnComment com, dp) -> [(com, dp)] + _ -> [] + ) + +filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns +filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) + +-- | True if there are any comments that are +-- a) connected to any node below (in AST sense) the given node AND +-- b) after (in source code order) the node. +hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsBelow ast@(L l _) = + List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) + <$> astConnectedComments ast + +hasCommentsBetween + :: Data ast + => GHC.Located ast + -> AnnKeywordId + -> AnnKeywordId + -> ToBriDocM Bool +hasCommentsBetween ast leftKey rightKey = do + mAnn <- astAnn ast + let + go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest + case mAnn of + Nothing -> pure False + Just ann -> pure $ go1 $ ExactPrint.annsDP ann + +-- | True if there are any comments that are connected to any node below (in AST +-- sense) the given node +hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast + +-- | True if there are any regular comments connected to any node below (in AST +-- sense) the given node +hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected ast = + any isRegularComment <$> astConnectedComments ast + +-- | Regular comments are comments that are actually "source code comments", +-- i.e. things that start with "--" or "{-". In contrast to comment-annotations +-- used by ghc-exactprint for capturing symbols (and their exact positioning). +-- +-- Only the type instance layouter makes use of this filter currently, but +-- it might make sense to apply it more aggressively or make it the default - +-- I believe that most of the time we branch on the existence of comments, we +-- only care about "regular" comments. We simply did not need the distinction +-- because "irregular" comments are not that common outside of type/data decls. +isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool +isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst + +astConnectedComments + :: Data ast + => GHC.Located ast + -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] +astConnectedComments ast = do + anns <- filterAnns ast <$> mAsk + pure $ extractAllComments =<< Map.elems anns + +hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsPrior ast = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + +hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsRest ast = astAnn ast <&> \case + Nothing -> False + Just ann -> any isRegularComment (extractRestComments ann) + +hasAnnKeywordComment + :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just ann -> any hasK (extractAllComments ann) + where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + +hasAnnKeyword + :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) + => Located a + -> AnnKeywordId + -> m Bool +hasAnnKeyword ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + where + hasK (ExactPrint.Types.G x, _) = x == annKeyword + hasK _ = False + +astAnn + :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) + => GHC.Located ast + -> m (Maybe Annotation) +astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk + +-- new BriDoc stuff + +allocateNode + :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered +allocateNode bd = do + i <- allocNodeIndex + return (i, bd) + +allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int +allocNodeIndex = do + NodeAllocIndex i <- mGet + mSet $ NodeAllocIndex (i + 1) + return i + +-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docEmpty = allocateNode BDFEmpty +-- +-- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered +-- docLit t = allocateNode $ BDFLit t +-- +-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) +-- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered +-- docExt x anns shouldAddComment = allocateNode $ BDFExternal +-- (ExactPrint.Types.mkAnnKey x) +-- (foldedAnnKeys x) +-- shouldAddComment +-- (Text.pack $ ExactPrint.exactPrint x anns) +-- +-- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered +-- docAlt l = allocateNode . BDFAlt =<< sequence l +-- +-- +-- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered +-- docSeq l = allocateNode . BDFSeq =<< sequence l +-- +-- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered +-- docLines l = allocateNode . BDFLines =<< sequence l +-- +-- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered +-- docCols sig l = allocateNode . BDFCols sig =<< sequence l +-- +-- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered +-- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm +-- +-- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm +-- +-- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm +-- +-- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docSeparator = allocateNode BDFSeparator +-- +-- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered +-- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm +-- +-- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered +-- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm +-- +-- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm +-- +-- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- appSep x = docSeq [x, docSeparator] +-- +-- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docCommaSep = appSep $ docLit $ Text.pack "," +-- +-- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered +-- docParenLSep = appSep $ docLit $ Text.pack "(" +-- +-- +-- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) +-- => Located ast +-- -> m BriDocNumbered +-- -> m BriDocNumbered +-- docPostComment ast bdm = do +-- bd <- bdm +-- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd +-- +-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) +-- => Located ast +-- -> m BriDocNumbered +-- -> m BriDocNumbered +-- docWrapNode ast bdm = do +-- bd <- bdm +-- i1 <- allocNodeIndex +-- i2 <- allocNodeIndex +-- return +-- $ (,) i1 +-- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) +-- $ (,) i2 +-- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) +-- $ bd +-- +-- docPar :: MonadMultiState NodeAllocIndex m +-- => m BriDocNumbered +-- -> m BriDocNumbered +-- -> m BriDocNumbered +-- docPar lineM indentedM = do +-- line <- lineM +-- indented <- indentedM +-- allocateNode $ BDFPar BrIndentNone line indented +-- +-- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm +-- +-- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered +-- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm +-- +-- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered +-- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd + +docEmpty :: ToBriDocM BriDocNumbered +docEmpty = allocateNode BDFEmpty + +docLit :: Text -> ToBriDocM BriDocNumbered +docLit t = allocateNode $ BDFLit t + +docLitS :: String -> ToBriDocM BriDocNumbered +docLitS s = allocateNode $ BDFLit $ Text.pack s + +docExt + :: (ExactPrint.Annotate.Annotate ast) + => Located ast + -> ExactPrint.Types.Anns + -> Bool + -> ToBriDocM BriDocNumbered +docExt x anns shouldAddComment = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey x) + (foldedAnnKeys x) + shouldAddComment + (Text.pack $ ExactPrint.exactPrint x anns) + +docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docAlt l = allocateNode . BDFAlt =<< sequence l + +newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) + deriving (Functor, Applicative, Monad) + +addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () +addAlternativeCond cond doc = when cond (addAlternative doc) + +addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () +addAlternative = CollectAltM . Writer.tell . (: []) + +runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered +runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action + + +docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docSeq [] = docEmpty +docSeq l = allocateNode . BDFSeq =<< sequence l + +docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docLines l = allocateNode . BDFLines =<< sequence l + +docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docCols sig l = allocateNode . BDFCols sig =<< sequence l + +docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm + +docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetBaseY bdm = do + bd <- bdm + -- the order here is important so that these two nodes can be treated + -- properly over at `transformAlts`. + n1 <- allocateNode $ BDFBaseYPushCur bd + n2 <- allocateNode $ BDFBaseYPop n1 + return n2 + +docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetIndentLevel bdm = do + bd <- bdm + n1 <- allocateNode $ BDFIndentLevelPushCur bd + n2 <- allocateNode $ BDFIndentLevelPop n1 + return n2 + +docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetBaseAndIndent = docSetBaseY . docSetIndentLevel + +docSeparator :: ToBriDocM BriDocNumbered +docSeparator = allocateNode BDFSeparator + +docAnnotationPrior + :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAnnotationPrior annKey bdm = + allocateNode . BDFAnnotationPrior annKey =<< bdm + +docAnnotationKW + :: AnnKey + -> Maybe AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docAnnotationKW annKey kw bdm = + allocateNode . BDFAnnotationKW annKey kw =<< bdm + +docMoveToKWDP + :: AnnKey + -> AnnKeywordId + -> Bool + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docMoveToKWDP annKey kw shouldRestoreIndent bdm = + allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm + +docAnnotationRest + :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm + +docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm + +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm + +docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm + +docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm + +docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docDebug s bdm = allocateNode . BDFDebug s =<< bdm + +appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +appSep x = docSeq [x, docSeparator] + +docCommaSep :: ToBriDocM BriDocNumbered +docCommaSep = appSep $ docLit $ Text.pack "," + +docParenLSep :: ToBriDocM BriDocNumbered +docParenLSep = appSep docParenL + +-- TODO: we don't make consistent use of these (yet). However, I think the +-- most readable approach overall might be something else: define +-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. +-- I think those two would make the usage most readable. +-- lit "(" and appSep (lit "(") are understandable and short without +-- introducing a new top-level binding for all types of parentheses. +docParenL :: ToBriDocM BriDocNumbered +docParenL = docLit $ Text.pack "(" + +docParenR :: ToBriDocM BriDocNumbered +docParenR = docLit $ Text.pack ")" + +docParenHashLSep :: ToBriDocM BriDocNumbered +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] + +docParenHashRSep :: ToBriDocM BriDocNumbered +docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] + +docBracketL :: ToBriDocM BriDocNumbered +docBracketL = docLit $ Text.pack "[" + +docBracketR :: ToBriDocM BriDocNumbered +docBracketR = docLit $ Text.pack "]" + + +docTick :: ToBriDocM BriDocNumbered +docTick = docLit $ Text.pack "'" + +docNodeAnnKW + :: Data.Data.Data ast + => Located ast + -> Maybe AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docNodeAnnKW ast kw bdm = + docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm + +docNodeMoveToKWDP + :: Data.Data.Data ast + => Located ast + -> AnnKeywordId + -> Bool + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm + +class DocWrapable a where + docWrapNode :: ( Data.Data.Data ast) + => Located ast + -> a + -> a + docWrapNodePrior :: ( Data.Data.Data ast) + => Located ast + -> a + -> a + docWrapNodeRest :: ( Data.Data.Data ast) + => Located ast + -> a + -> a + +instance DocWrapable (ToBriDocM BriDocNumbered) where + docWrapNode ast bdm = do + bd <- bdm + i1 <- allocNodeIndex + i2 <- allocNodeIndex + return + $ (,) i1 + $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ (,) i2 + $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) + $ bd + docWrapNodePrior ast bdm = do + bd <- bdm + i1 <- allocNodeIndex + return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd + docWrapNodeRest ast bdm = do + bd <- bdm + i2 <- allocNodeIndex + return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd + +instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where + docWrapNode ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNode ast bd] + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> + [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] + _ -> error "cannot happen (TM)" + docWrapNodePrior ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNodePrior ast bd] + (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR + docWrapNodeRest ast bdms = case reverse bdms of + [] -> [] + (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where + docWrapNode ast bdsm = do + bds <- bdsm + case bds of + [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. + [bd] -> do + bd' <- docWrapNode ast (return bd) + return [bd'] + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do + bd1' <- docWrapNodePrior ast (return bd1) + bdN' <- docWrapNodeRest ast (return bdN) + return $ [bd1'] ++ reverse bdM ++ [bdN'] + _ -> error "cannot happen (TM)" + docWrapNodePrior ast bdsm = do + bds <- bdsm + case bds of + [] -> return [] + (bd1 : bdR) -> do + bd1' <- docWrapNodePrior ast (return bd1) + return (bd1' : bdR) + docWrapNodeRest ast bdsm = do + bds <- bdsm + case reverse bds of + [] -> return [] + (bdN : bdR) -> do + bdN' <- docWrapNodeRest ast (return bdN) + return $ reverse (bdN' : bdR) + +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where + docWrapNode ast bdsm = do + bds <- bdsm + case Seq.viewl bds of + Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. + bd1 Seq.:< rest -> case Seq.viewr rest of + Seq.EmptyR -> do + bd1' <- docWrapNode ast (return bd1) + return $ Seq.singleton bd1' + bdM Seq.:> bdN -> do + bd1' <- docWrapNodePrior ast (return bd1) + bdN' <- docWrapNodeRest ast (return bdN) + return $ (bd1' Seq.<| bdM) Seq.|> bdN' + docWrapNodePrior ast bdsm = do + bds <- bdsm + case Seq.viewl bds of + Seq.EmptyL -> return Seq.empty + bd1 Seq.:< bdR -> do + bd1' <- docWrapNodePrior ast (return bd1) + return $ bd1' Seq.<| bdR + docWrapNodeRest ast bdsm = do + bds <- bdsm + case Seq.viewr bds of + Seq.EmptyR -> return Seq.empty + bdR Seq.:> bdN -> do + bdN' <- docWrapNodeRest ast (return bdN) + return $ bdR Seq.|> bdN' + +instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where + docWrapNode ast stuffM = do + (bds, bd, x) <- stuffM + if null bds + then do + bd' <- docWrapNode ast (return bd) + return (bds, bd', x) + else do + bds' <- docWrapNodePrior ast (return bds) + bd' <- docWrapNodeRest ast (return bd) + return (bds', bd', x) + docWrapNodePrior ast stuffM = do + (bds, bd, x) <- stuffM + bds' <- docWrapNodePrior ast (return bds) + return (bds', bd, x) + docWrapNodeRest ast stuffM = do + (bds, bd, x) <- stuffM + bd' <- docWrapNodeRest ast (return bd) + return (bds, bd', x) + + + +docPar + :: ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docPar lineM indentedM = do + line <- lineM + indented <- indentedM + allocateNode $ BDFPar BrIndentNone line indented + +docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm + +docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm + +docEnsureIndent + :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd + +unknownNodeError + :: Data.Data.Data ast + => String + -> GenLocated GHC.SrcSpan ast + -> ToBriDocM BriDocNumbered +unknownNodeError infoStr ast = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + +spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] +spacifyDocs [] = [] +spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] + +briDocMToPPM :: ToBriDocM a -> PPMLocal a +briDocMToPPM m = do + (x, errs, debugs) <- briDocMToPPMInner m + mTell debugs + mTell errs + return x + +briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) +briDocMToPPMInner m = do + readers <- MultiRWSS.mGetRawR + let + ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m + pure (x, errs, debugs) + +docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) +docSharedWrapper f x = return <$> f x diff --git a/source/library/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Brittany/Internal/Layouters/DataDecl.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/DataDecl.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Layouters.DataDecl where + +import qualified Data.Data +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (GenLocated(L), Located) +import qualified GHC +import GHC.Hs +import qualified GHC.OldList as List +import 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 + + + +layoutDataDecl + :: Located (TyClDecl GhcPs) + -> Located RdrName + -> LHsQTyVars GhcPs + -> HsDataDefn GhcPs + -> ToBriDocM BriDocNumbered +layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of + -- newtype MyType a b = MyType .. + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) + -> docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl + + + -- data MyData a b + -- (zero constructors) + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> + docWrapNode ltycl $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "data" + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + ] + + -- data MyData = MyData .. + -- data MyData = MyData { .. } + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) + -> docWrapNode ltycl $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of + Nothing -> pure Nothing + Just x -> Just . pure <$> x + rhsContextDocMay <- case mRhsContext of + Nothing -> pure Nothing + Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt + rhsDoc <- return <$> createDetailsDoc consNameStr details + consDoc <- + fmap pure + $ docNonBottomSpacing + $ case (forallDocMay, rhsContextDocMay) of + (Just forallDoc, Just rhsContextDoc) -> docLines + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq + [ docLitS "." + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + ] + (Just forallDoc, Nothing) -> docLines + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq [docLitS ".", docSeparator, rhsDoc] + ] + (Nothing, Just rhsContextDoc) -> docSeq + [ docLitS "=" + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + (Nothing, Nothing) -> + docSeq [docLitS "=", docSeparator, rhsDoc] + createDerivingPar mDerivs $ docAlt + [ -- data D = forall a . Show a => D a + docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline $ lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + ] + , docLitS "=" + , docSeparator + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ] + , -- data D + -- = forall a . Show a => D a + docAddBaseY BrIndentRegular $ docPar + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + (docSeq + [ docLitS "=" + , docSeparator + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ] + ) + , -- data D + -- = forall a + -- . Show a => + -- D a + docAddBaseY BrIndentRegular $ docPar + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + consDoc + , -- data + -- Show a => + -- D + -- = forall a + -- . Show a => + -- D a + -- This alternative is only for -XDatatypeContexts. + -- But I think it is rather unlikely this will trigger without + -- -XDataTypeContexts, especially with the `docNonBottomSpacing` + -- above, so while not strictly necessary, this should not + -- hurt. + docAddBaseY BrIndentRegular $ docPar + (docLitS "data") + (docLines + [ lhsContextDoc + , docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [appSep $ docLit nameStr, tyVarLine] + , consDoc + ] + ) + ] + _ -> briDocByExactNoComment ltycl + + _ -> briDocByExactNoComment ltycl + +createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered +createContextDoc [] = docEmpty +createContextDoc [t] = + docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] +createContextDoc (t1 : tR) = do + t1Doc <- docSharedWrapper layoutType t1 + tRDocs <- tR `forM` docSharedWrapper layoutType + docAlt + [ docSeq + [ docLitS "(" + , docForceSingleline $ docSeq $ List.intersperse + docCommaSep + (t1Doc : tRDocs) + , docLitS ") =>" + , docSeparator + ] + , docLines $ join + [ [docSeq [docLitS "(", docSeparator, t1Doc]] + , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , [docLitS ") =>", docSeparator] + ] + ] + +createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered +createBndrDoc bs = do + tyVarDocs <- bs `forM` \case + (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar _ _ext lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> + case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] + +createDerivingPar + :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +createDerivingPar derivs mainDoc = do + case derivs of + (L _ []) -> mainDoc + (L _ types) -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc + <$> types + +derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = + maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in docSeq + [ docDeriving + , docWrapNodePrior types $ lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docWrapNodeRest types + $ docSeq + $ List.intersperse docCommaSep + $ ts + <&> \case + HsIB _ t -> layoutType t + , whenMoreThan1Type ")" + , rhsStrategy + ] + where + strategyLeftRight = \case + (L _ StockStrategy) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) + lVia@(L _ (ViaStrategy viaTypes)) -> + ( docEmpty + , case viaTypes of + HsIB _ext t -> + docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] + ) + +docDeriving :: ToBriDocM BriDocNumbered +docDeriving = docLitS "deriving" + +createDetailsDoc + :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) +createDetailsDoc consNameStr details = case details of + PrefixCon args -> do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + singleLine = docSeq + [ docLit consNameStr + , docSeparator + , docForceSingleline + $ docSeq + $ List.intersperse docSeparator + $ fmap hsScaledThing args + <&> layoutType + ] + leftIndented = + docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType + <$> fmap hsScaledThing args + multiAppended = docSeq + [ docLit consNameStr + , docSeparator + , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args + ] + multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + (docLit consNameStr) + (docLines $ layoutType <$> fmap hsScaledThing args) + case indentPolicy of + IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] + IndentPolicyFree -> + docAlt [singleLine, multiAppended, multiIndented, leftIndented] + RecCon (L _ []) -> + docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_ : _)) -> do + let ((fName1, fType1) : fDocR) = mkFieldDocs fields + -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + let allowSingleline = False + docAddBaseY BrIndentRegular $ runFilteredAlternative $ do + -- single-line: { i :: Int, b :: Bool } + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR + ] + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols + ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols + ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName + , docSeq [docLitS "::", docSeparator] + , docForceSingleline fType + ] + , docSeq + [ docLitS "," + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName + (docSeq [docLitS "::", docSeparator, fType]) + ] + ] + , docLitS "}" + ] + ) + InfixCon arg1 arg2 -> docSeq + [ layoutType $ hsScaledThing arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType $ hsScaledThing arg2 + ] + where + mkFieldDocs + :: [LConDeclField GhcPs] + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + mkFieldDocs = fmap $ \lField -> case lField of + L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t + +createForallDoc + :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = + Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] + +createNamesAndTypeDoc + :: Data.Data.Data ast + => Located ast + -> [GenLocated t (FieldOcc GhcPs)] + -> Located (HsType GhcPs) + -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) +createNamesAndTypeDoc lField names t = + ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq + [ docSeq $ List.intersperse docCommaSep $ names <&> \case + L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName + ] + , docWrapNodeRest lField $ layoutType t + ) diff --git a/source/library/Brittany/Internal/Layouters/Decl.hs b/source/library/Brittany/Internal/Layouters/Decl.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Decl.hs @@ -0,0 +1,998 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Brittany.Internal.Layouters.Decl where + +import qualified Data.Data +import qualified Data.Foldable +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC.Data.Bag (bagToList, emptyBag) +import qualified GHC.Data.FastString as FastString +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic + ( Activation(..) + , InlinePragma(..) + , InlineSpec(..) + , LexicalFixity(..) + , RuleMatchInfo(..) + ) +import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) +import 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 + + + +layoutDecl :: ToBriDoc HsDecl +layoutDecl d@(L loc decl) = case decl of + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + InstD _ (TyFamInstD _ tfid) -> + withTransformedAnns d $ layoutTyFamInstDecl False d tfid + InstD _ (ClsInstD _ inst) -> + withTransformedAnns d $ layoutClsInst (L loc inst) + _ -> briDocByExactNoComment d + +-------------------------------------------------------------------------------- +-- Sig +-------------------------------------------------------------------------------- + +layoutSig :: ToBriDoc Sig +layoutSig lsig@(L _loc sig) = case sig of + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ + InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> + docWrapNode lsig $ do + nameStr <- lrdrNameToTextAnn name + specStr <- specStringCompat lsig spec + let + phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let + conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " + docLit + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + <> nameStr + <> Text.pack " #-}" + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ + PatSynSig _ names (HsIB _ typ) -> + layoutNamesAndType (Just "pattern") names typ + _ -> briDocByExactNoComment lsig -- TODO + where + layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do + let + keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] + nameStrs <- names `forM` lrdrNameToTextAnn + let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsBelow lsig + shouldBeHanging <- + mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack + if shouldBeHanging + then + docSeq + $ [ appSep + $ docWrapNodeRest lsig + $ docSeq + $ keyDoc + <> [docLit nameStr] + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ] + ] + else layoutLhsAndType + hasComments + (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) + "::" + typeDoc + +specStringCompat + :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String +specStringCompat ast = \case + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " + +layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) +layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of + BodyStmt _ body _ _ -> layoutExpr body + BindStmt _ lPat expr -> do + patDoc <- docSharedWrapper layoutPat lPat + expDoc <- docSharedWrapper layoutExpr expr + docCols + ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO + + +-------------------------------------------------------------------------------- +-- HsBind +-------------------------------------------------------------------------------- + +layoutBind + :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) +layoutBind lbind@(L _ bind) = case bind of + FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" + funcPatDocs <- + docWrapNode lbind + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches + return $ Left $ funcPatDocs + PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do + patDocs <- colsWrapPat =<< layoutPat pat + clauseDocs <- layoutGrhs `mapM` grhss + mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? + binderDoc <- docLit $ Text.pack "=" + hasComments <- hasAnyCommentsBelow lbind + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal + Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereArg + hasComments + PatSynBind _ (PSB _ patID lpat rpat dir) -> do + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat + _ -> Right <$> unknownNodeError "" lbind +layoutIPBind :: ToBriDoc IPBind +layoutIPBind lipbind@(L _ bind) = case bind of + IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" + IPBind _ (Left (L _ (HsIPName name))) expr -> do + ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name + binderDoc <- docLit $ Text.pack "=" + exprDoc <- layoutExpr expr + hasComments <- hasAnyCommentsBelow lipbind + layoutPatternBindFinal + Nothing + binderDoc + (Just ipName) + [([], exprDoc, expr)] + Nothing + hasComments + + +data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) + | BagSig (LSig GhcPs) + +bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan +bindOrSigtoSrcSpan (BagBind (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l + +layoutLocalBinds + :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) +layoutLocalBinds lbinds@(L _ binds) = case binds of + -- HsValBinds (ValBindsIn lhsBindsLR []) -> + -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering + -- x@(HsValBinds (ValBindsIn{})) -> + -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x + HsValBinds _ (ValBinds _ bindlrs sigs) -> do + let + unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + docs <- docWrapNode lbinds $ join <$> ordered `forM` \case + BagBind b -> either id return <$> layoutBind b + BagSig s -> return <$> layoutSig s + return $ Just $ docs +-- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> + HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" + HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb + EmptyLocalBinds{} -> return $ Nothing + +-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is +-- parSpacing stuff.B +layoutGrhs + :: LGRHS GhcPs (LHsExpr GhcPs) + -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) +layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do + guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards + bodyDoc <- layoutExpr body + return (guardDocs, bodyDoc, body) + +layoutPatternBind + :: Maybe Text + -> BriDocNumbered + -> LMatch GhcPs (LHsExpr GhcPs) + -> ToBriDocM BriDocNumbered +layoutPatternBind funId binderDoc lmatch@(L _ match) = do + let pats = m_pats match + let (GRHSs _ grhss whereBinds) = m_grhss match + patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + let isInfix = isInfixMatch match + mIdStr <- case match of + Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId + _ -> pure Nothing + let mIdStr' = fixPatternBindIdentifier match <$> mIdStr + patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of + (Just idStr, p1 : p2 : pr) | isInfix -> if null pr + then docCols + ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else docCols + ColPatternsFuncInfix + ([ docCols + ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR + ] + ] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) + (Just idStr, []) -> docLit idStr + (Just idStr, ps) -> + docCols ColPatternsFuncPrefix + $ appSep (docLit $ idStr) + : (spacifyDocs $ docForceSingleline <$> ps) + (Nothing, ps) -> + docCols ColPatterns + $ (List.intersperse docSeparator $ docForceSingleline <$> ps) + clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss + mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) + let alignmentToken = if null pats then Nothing else funId + hasComments <- hasAnyCommentsBelow lmatch + layoutPatternBindFinal + alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereArg + hasComments + +fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier match idStr = go $ m_ctxt match + where + go = \case + (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr + (FunRhs _ _ NoSrcStrict) -> idStr + (StmtCtxt ctx1) -> goInner ctx1 + _ -> idStr + -- I have really no idea if this path ever occurs, but better safe than + -- risking another "drop bangpatterns" bugs. + goInner = \case + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 + (TransStmtCtxt ctx1) -> goInner ctx1 + _ -> idStr + +layoutPatternBindFinal + :: Maybe Text + -> BriDocNumbered + -> Maybe BriDocNumbered + -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] + -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) + -- ^ AnnKey for the node that contains the AnnWhere position annotation + -> Bool + -> ToBriDocM BriDocNumbered +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments + = do + let + patPartInline = case mPatDoc of + Nothing -> [] + Just patDoc -> [appSep $ docForceSingleline $ return patDoc] + patPartParWrap = case mPatDoc of + Nothing -> id + Just patDoc -> docPar (return patDoc) + whereIndent <- do + shouldSpecial <- + mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack + regularIndentAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + [ docEnsureIndent BrIndentRegular + $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ return w + ] + ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let + singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty + [g] -> docSeq + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + gs -> + docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ (List.intersperse + docCommaSep + (docForceSingleline . return <$> gs) + ) + wherePart = case mWhereDocs of + Nothing -> Just docEmpty + Just (_, [w]) -> Just $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> Nothing + + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + + runFilteredAlternative $ do + + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' + ] + ] + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine + + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` + + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline $ docSeq + [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1 : gr) -> + (docSeq [appSep $ docLit $ Text.pack "|", return g1] + : (gr <&> \g -> + docSeq [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + +-- | Layout a pattern synonym binding +layoutPatSynBind + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> HsPatSynDir GhcPs + -> LPat GhcPs + -> ToBriDocM BriDocNumbered +layoutPatSynBind name patSynDetails patDir rpat = do + let + patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" + mWhereDocs <- layoutPatSynWhere patDir + headDoc <- + fmap pure + $ docSeq + $ [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] + runFilteredAlternative $ do + addAlternative + $ + -- pattern .. where + -- .. + -- .. + docAddBaseY BrIndentRegular + $ docSeq + ([headDoc, docSeparator, body] ++ case mWhereDocs of + Just ds -> [docSeparator, docPar whereDoc (docLines ds)] + Nothing -> [] + ) + addAlternative + $ + -- pattern .. = + -- .. + -- pattern .. <- + -- .. where + -- .. + -- .. + docAddBaseY BrIndentRegular + $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) + ) + +-- | Helper method for the left hand side of a pattern synonym +layoutLPatSyn + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> ToBriDocM BriDocNumbered +layoutLPatSyn name (PrefixCon vars) = do + docName <- lrdrNameToTextAnn name + names <- mapM lrdrNameToTextAnn vars + docSeq . fmap appSep $ docLit docName : (docLit <$> names) +layoutLPatSyn name (InfixCon left right) = do + leftDoc <- lrdrNameToTextAnn left + docName <- lrdrNameToTextAnn name + rightDoc <- lrdrNameToTextAnn right + docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] +layoutLPatSyn name (RecCon recArgs) = do + docName <- lrdrNameToTextAnn name + args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs + docSeq + . fmap docLit + $ [docName, Text.pack " { "] + <> intersperse (Text.pack ", ") args + <> [Text.pack " }"] + +-- | Helper method to get the where clause from of explicitly bidirectional +-- pattern synonyms +layoutPatSynWhere + :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere hs = case hs of + ExplicitBidirectional (MG _ (L _ lbinds) _) -> do + binderDoc <- docLit $ Text.pack "=" + Just + <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + _ -> pure Nothing + +-------------------------------------------------------------------------------- +-- TyClDecl +-------------------------------------------------------------------------------- + +layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl ltycl@(L _loc tycl) = case tycl of + SynDecl _ name vars fixity typ -> do + let + isInfix = case fixity of + Prefix -> False + Infix -> True + -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + -- let parenWrapper = if hasTrailingParen + -- then appSep . docWrapNodeRest ltycl + -- else id + let wrapNodeRest = docWrapNodeRest ltycl + docWrapNodePrior ltycl + $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ + DataDecl _ext name tyVars _ dataDefn -> + layoutDataDecl ltycl name tyVars dataDefn + _ -> briDocByExactNoComment ltycl + +layoutSynDecl + :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Located (IdP GhcPs) + -> [LHsTyVarBndr () GhcPs] + -> LHsType GhcPs + -> ToBriDocM BriDocNumbered +layoutSynDecl isInfix wrapNodeRest name vars typ = do + nameStr <- lrdrNameToTextAnn name + let + lhs = appSep . wrapNodeRest $ if isInfix + then do + let (a : b : rest) = vars + hasOwnParens <- hasAnnKeywordComment a AnnOpenP + -- This isn't quite right, but does give syntactically valid results + let needsParens = not (null rest) || hasOwnParens + docSeq + $ [docLit $ Text.pack "type", docSeparator] + ++ [ docParenL | needsParens ] + ++ [ layoutTyVarBndr False a + , docSeparator + , docLit nameStr + , docSeparator + , layoutTyVarBndr False b + ] + ++ [ docParenR | needsParens ] + ++ fmap (layoutTyVarBndr True) rest + else + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] + ++ fmap (layoutTyVarBndr True) vars + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsConnected typ + layoutLhsAndType hasComments sharedLhs "=" typeDoc + +layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) +layoutTyVarBndr needsSep lbndr@(L _ bndr) = do + docWrapNodePrior lbndr $ case bndr of + UserTyVar _ _ name -> do + nameStr <- lrdrNameToTextAnn name + docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] + KindedTyVar _ _ name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsSep ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] + + +-------------------------------------------------------------------------------- +-- TyFamInstDecl +-------------------------------------------------------------------------------- + + + +layoutTyFamInstDecl + :: Data.Data.Data a + => Bool + -> Located a + -> TyFamInstDecl GhcPs + -> ToBriDocM BriDocNumbered +layoutTyFamInstDecl inClass outerNode tfid = do + let + FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid + -- bndrsMay isJust e.g. with + -- type instance forall a . MyType (Maybe a) = Either () a + innerNode = outerNode + docWrapNodePrior outerNode $ do + nameStr <- lrdrNameToTextAnn name + needsParens <- hasAnnKeyword outerNode AnnOpenP + let + instanceDoc = if inClass + then docLit $ Text.pack "type" + else docSeq + [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] + makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered + makeForallDoc bndrs = do + bndrDocs <- layoutTyVarBndrs bndrs + docSeq + ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs + ) + lhs = + docWrapNode innerNode + . docSeq + $ [appSep instanceDoc] + ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] + ++ [ docParenL | needsParens ] + ++ [appSep $ docWrapNode name $ docLit nameStr] + ++ intersperse docSeparator (layoutHsTyPats pats) + ++ [ docParenR | needsParens ] + hasComments <- + (||) + <$> hasAnyRegularCommentsConnected outerNode + <*> hasAnyRegularCommentsRest innerNode + typeDoc <- docSharedWrapper layoutType typ + layoutLhsAndType hasComments lhs "=" typeDoc + + +layoutHsTyPats + :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats pats = pats <&> \case + HsValArg tm -> layoutType tm + HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] + -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change + -- is a bit strange. Hopefully this does not ignore any important + -- annotations. + HsArgPar _l -> error "brittany internal error: HsArgPar{}" + +-------------------------------------------------------------------------------- +-- ClsInstDecl +-------------------------------------------------------------------------------- + +-- | Layout an @instance@ declaration +-- +-- Layout signatures and bindings using the corresponding layouters from the +-- top-level. Layout the instance head, type family instances, and data family +-- instances using ExactPrint. +layoutClsInst :: ToBriDoc ClsInstDecl +layoutClsInst lcid@(L _ cid) = docLines + [ layoutInstanceHead + , docEnsureIndent BrIndentRegular + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) + ] + where + layoutInstanceHead :: ToBriDocM BriDocNumbered + layoutInstanceHead = + briDocByExactNoComment + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren + <$> lcid + + removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs + removeChildren c = c + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] + , cid_datafam_insts = [] + } + + -- | Like 'docLines', but sorts the lines based on location + docSortedLines + :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered + docSortedLines l = + allocateNode + . BDFLines + . fmap unLoc + . List.sortOn (ExactPrint.rs . getLoc) + =<< sequence l + + layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) + layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig + + layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) + layoutAndLocateBind lbind@(L loc _) = + L loc <$> (joinBinds =<< layoutBind lbind) + + joinBinds + :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered + joinBinds = \case + Left ns -> docLines $ return <$> ns + Right n -> return n + + layoutAndLocateTyFamInsts + :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateTyFamInsts ltfid@(L loc tfid) = + L loc <$> layoutTyFamInstDecl True ltfid tfid + + layoutAndLocateDataFamInsts + :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) + layoutAndLocateDataFamInsts ldfid@(L loc _) = + L loc <$> layoutDataFamInstDecl ldfid + + -- | Send to ExactPrint then remove unecessary whitespace + layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl + layoutDataFamInstDecl ldfid = + fmap stripWhitespace <$> briDocByExactNoComment ldfid + + -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations + stripWhitespace :: BriDocF f -> BriDocF f + stripWhitespace (BDFExternal ann anns b t) = + BDFExternal ann anns b $ stripWhitespace' t + stripWhitespace b = b + + -- | This fixes two issues of output coming from Exactprinting + -- associated (data) type decls. Firstly we place the output into docLines, + -- so one newline coming from Exactprint is superfluous, so we drop the + -- first (empty) line. The second issue is Exactprint indents the first + -- member in a strange fashion: + -- + -- input: + -- + -- > instance MyClass Int where + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- output of just exactprinting the associated data type syntax node + -- + -- > + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- To fix this, we strip whitespace from the start of the comments and the + -- first line of the declaration, stopping when we see "data" or "type" at + -- the start of a line. I.e., this function yields + -- + -- > -- | This data is very important + -- > data MyData = IntData + -- > { intData :: String + -- > , intData2 :: Int + -- > } + -- + -- Downside apart from being a hacky and brittle fix is that this removes + -- possible additional indentation from comments before the first member. + -- + -- But the whole thing is just a temporary measure until brittany learns + -- to layout data/type decls. + stripWhitespace' :: Text -> Text + stripWhitespace' t = + Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t + where + go [] = [] + go (line1 : lineR) = case Text.stripStart line1 of + st + | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR + isTypeOrData t' = + (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "newtype" `Text.isPrefixOf` t') + || (Text.pack "data" `Text.isPrefixOf` t') + + +-------------------------------------------------------------------------------- +-- Common Helpers +-------------------------------------------------------------------------------- + +layoutLhsAndType + :: Bool + -> ToBriDocM BriDocNumbered + -> String + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +layoutLhsAndType hasComments lhs sep typeDoc = do + runFilteredAlternative $ do + -- (separators probably are "=" or "::") + -- lhs = type + -- lhs :: type + addAlternativeCond (not hasComments) $ docSeq + [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] + -- lhs + -- :: typeA + -- -> typeB + -- lhs + -- = typeA + -- -> typeB + addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols + ColTyOpPrefix + [ appSep $ docLitS sep + , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc + ] diff --git a/source/library/Brittany/Internal/Layouters/Expr.hs b/source/library/Brittany/Internal/Layouters/Expr.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Expr.hs @@ -0,0 +1,1086 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Layouters.Expr where + +import qualified Data.Data +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) +import qualified GHC.Data.FastString as FastString +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Types.Name +import 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 + + + +layoutExpr :: ToBriDoc HsExpr +layoutExpr lexpr@(L _ expr) = do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let allowFreeIndent = indentPolicy == IndentPolicyFree + docWrapNode lexpr $ case expr of + HsVar _ vname -> do + docLit =<< lrdrNameToTextAnn vname + HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname + HsRecFld{} -> do + -- TODO + briDocByExactInlineOnly "HsRecFld" lexpr + HsOverLabel _ext _reboundFromLabel name -> + let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label + HsIPVar _ext (HsIPName name) -> + let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label + HsOverLit _ olit -> do + allocateNode $ overLitValBriDoc $ ol_val olit + HsLit _ lit -> do + allocateNode $ litBriDoc lit + HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds{} <- llocals + , L _ (GRHS _ [] body) <- lgrhs + -> do + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let + shouldPrefixSeparator = case p of + L _ LazyPat{} -> isFirst + L _ BangPat{} -> isFirst + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- + docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let + funcPatternPartLine = docCols + ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing $ docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> unknownNodeError "HsLam too complex" lexpr + HsLamCase _ (MG _ (L _ []) _) -> do + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ (docLit $ Text.pack "\\case {}") + HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "\\case") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) + HsApp _ exp1@(L _ HsApp{}) exp2 -> do + let + gather + :: [LHsExpr GhcPs] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [LHsExpr GhcPs]) + gather list = \case + L _ (HsApp _ l r) -> gather (r : list) l + x -> (x, list) + let (headE, paramEs) = gather [exp2] exp1 + let + colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq + headDoc <- docSharedWrapper layoutExpr headE + paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs + hasComments <- hasAnyCommentsConnected exp2 + runFilteredAlternative $ do + -- foo x y + addAlternativeCond (not hasComments) + $ colsOrSequence + $ appSep (docForceSingleline headDoc) + : spacifyDocs (docForceSingleline <$> paramDocs) + -- foo x + -- y + addAlternativeCond allowFreeIndent $ docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY + $ docAddBaseY BrIndentRegular + $ docLines + $ docForceSingleline + <$> paramDocs + ] + -- foo + -- x + -- y + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docForceSingleline headDoc) + (docNonBottomSpacing $ docLines paramDocs) + -- ( multi + -- line + -- function + -- ) + -- x + -- y + addAlternative $ docAddBaseY BrIndentRegular $ docPar + headDoc + (docNonBottomSpacing $ docLines paramDocs) + HsApp _ exp1 exp2 -> do + -- TODO: if expDoc1 is some literal, we may want to create a docCols here. + expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc2 <- docSharedWrapper layoutExpr exp2 + docAlt + [ -- func arg + docSeq + [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + , -- func argline1 + -- arglines + -- e.g. + -- func Abc + -- { member1 = True + -- , member2 = 13 + -- } + docSetParSpacing -- this is most likely superfluous because + -- this is a sequence of a one-line and a par-space + -- anyways, so it is _always_ par-spaced. + $ docAddBaseY BrIndentRegular + $ docSeq + [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] + , -- func + -- arg + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docForceSingleline expDoc1) + (docNonBottomSpacing expDoc2) + , -- fu + -- nc + -- ar + -- gument + docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 + ] + HsAppType _ exp1 (HsWC _ ty1) -> do + t <- docSharedWrapper layoutType ty1 + e <- docSharedWrapper layoutExpr exp1 + docAlt + [ docSeq + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar e (docSeq [docLit $ Text.pack "@", t]) + ] + OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do + let + gather + :: [(LHsExpr GhcPs, LHsExpr GhcPs)] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) + gather opExprList = \case + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft + leftOperandDoc <- docSharedWrapper layoutExpr leftOperand + appListDocs <- appList `forM` \(x, y) -> + [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight + allowSinglelinePar <- do + hasComLeft <- hasAnyCommentsConnected expLeft + hasComOp <- hasAnyCommentsConnected expOp + pure $ not hasComLeft && not hasComOp + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + runFilteredAlternative $ do + -- > one + two + three + -- or + -- > one + two + case x of + -- > _ -> three + addAlternativeCond allowSinglelinePar $ docSeq + [ appSep $ docForceSingleline leftOperandDoc + , docSeq $ appListDocs <&> \(od, ed) -> docSeq + [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc + ] + -- this case rather leads to some unfortunate layouting than to anything + -- useful; disabling for now. (it interfers with cols stuff.) + -- addAlternative + -- $ docSetBaseY + -- $ docPar + -- leftOperandDoc + -- ( docLines + -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + -- ) + -- > one + -- > + two + -- > + three + addAlternative $ docPar + leftOperandDoc + (docLines + $ (appListDocs <&> \(od, ed) -> + docCols ColOpPrefix [appSep od, docSetBaseY ed] + ) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) + OpApp _ expLeft expOp expRight -> do + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp + expDocRight <- docSharedWrapper layoutExpr expRight + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let + leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False + runFilteredAlternative $ do + -- one-line + addAlternative $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceSingleline expDocRight + ] + -- -- line + freely indented block for right expression + -- addAlternative + -- $ docSeq + -- [ appSep $ docForceSingleline expDocLeft + -- , appSep $ docForceSingleline expDocOp + -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight + -- ] + -- two-line + addAlternative $ do + let + expDocOpAndRight = docForceSingleline $ docCols + ColOpPrefix + [appSep $ expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight + -- TODO: in both cases, we don't force expDocLeft to be + -- single-line, which has certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. + -- one-line + par + addAlternativeCond allowPar $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceParSpacing expDocRight + ] + -- more lines + addAlternative $ do + let + expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight + NegApp _ op _ -> do + opDoc <- docSharedWrapper layoutExpr op + docSeq [docLit $ Text.pack "-", opDoc] + HsPar _ innerExp -> do + innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp + docAlt + [ docSeq + [ docLit $ Text.pack "(" + , docForceSingleline innerExpDoc + , docLit $ Text.pack ")" + ] + , docSetBaseY $ docLines + [ docCols + ColOpPrefix + [ docLit $ Text.pack "(" + , docAddBaseY (BrIndentSpecial 2) innerExpDoc + ] + , docLit $ Text.pack ")" + ] + ] + SectionL _ left op -> do -- TODO: add to testsuite + leftDoc <- docSharedWrapper layoutExpr left + opDoc <- docSharedWrapper layoutExpr op + docSeq [leftDoc, docSeparator, opDoc] + SectionR _ op right -> do -- TODO: add to testsuite + opDoc <- docSharedWrapper layoutExpr op + rightDoc <- docSharedWrapper layoutExpr right + docSeq [opDoc, docSeparator, rightDoc] + ExplicitTuple _ args boxity -> do + let + argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e) + (L _ (Missing NoExtField)) -> (arg, Nothing) + argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> + docWrapNode arg $ maybe docEmpty layoutExpr exprM + hasComments <- + orM + (hasCommentsBetween lexpr AnnOpenP AnnCloseP + : map hasAnyCommentsBelow args + ) + let + (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) + case splitFirstLast argDocs of + FirstLastEmpty -> + docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] + FirstLastSingleton e -> docAlt + [ docCols + ColTuple + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + , closeLit + ] + , docSetBaseY $ docLines + [ docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + ] + , closeLit + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] + ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) + ++ [ docSeq + [ docCommaSep + , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) + , closeLit + ] + ] + addAlternative + $ let + start = docCols ColTuples [appSep openLit, e1] + linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] + lineN = docCols + ColTuples + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + HsCase _ cExp (MG _ (L _ []) _) -> do + cExpDoc <- docSharedWrapper layoutExpr cExp + docAlt + [ docAddBaseY BrIndentRegular $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] + , docPar + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") + ] + HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do + cExpDoc <- docSharedWrapper layoutExpr cExp + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches + docAlt + [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of" + ] + ) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) + , docPar + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "of") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) + ) + ] + HsIf _ ifExpr thenExpr elseExpr -> do + ifExprDoc <- docSharedWrapper layoutExpr ifExpr + thenExprDoc <- docSharedWrapper layoutExpr thenExpr + elseExprDoc <- docSharedWrapper layoutExpr elseExpr + hasComments <- hasAnyCommentsBelow lexpr + let + maySpecialIndent = case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 + -- TODO: some of the alternatives (especially last and last-but-one) + -- overlap. + docSetIndentLevel $ runFilteredAlternative $ do + -- if _ then _ else _ + addAlternativeCond (not hasComments) $ docSeq + [ appSep $ docLit $ Text.pack "if" + , appSep $ docForceSingleline ifExprDoc + , appSep $ docLit $ Text.pack "then" + , appSep $ docForceSingleline thenExprDoc + , appSep $ docLit $ Text.pack "else" + , docForceSingleline elseExprDoc + ] + -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docNonBottomSpacing + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ] + ) + -- either + -- if multi + -- line + -- condition + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if multi + -- line + -- condition + -- then + -- stuff + -- else + -- stuff + -- note that this does _not_ have par-spacing + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ] + ) + addAlternative $ docSetBaseY $ docLines + [ docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + HsMultiIf _ cases -> do + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" + hasComments <- hasAnyCommentsBelow lexpr + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "if") + (layoutPatternBindFinal + Nothing + binderDoc + Nothing + clauseDocs + Nothing + hasComments + ) + HsLet _ binds exp1 -> do + expDoc1 <- docSharedWrapper layoutExpr exp1 + -- We jump through some ugly hoops here to ensure proper sharing. + hasComments <- hasAnyCommentsBelow lexpr + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds + let + ifIndentFreeElse :: a -> a -> a + ifIndentFreeElse x y = case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x + -- this `docSetBaseAndIndent` might seem out of place (especially the + -- Indent part; setBase is necessary due to the use of docLines below), + -- but is here due to ghc-exactprint's DP handling of "let" in + -- particular. + -- Just pushing another indentation level is a straightforward approach + -- to making brittany idempotent, even though the result is non-optimal + -- if "let" is moved horizontally as part of the transformation, as the + -- comments before the first let item are moved horizontally with it. + docSetBaseAndIndent $ case mBindDocs of + Just [bindDoc] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ appSep $ docLit $ Text.pack "let" + , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline + bindDoc + , appSep $ docLit $ Text.pack "in" + , docForceSingleline expDoc1 + ] + addAlternative $ docLines + [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc + ] + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) + ] + , docAlt + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse + docSetBaseAndIndent + docForceSingleline + expDoc1 + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) + ] + ] + Just bindDocs@(_ : _) -> runFilteredAlternative $ do + --either + -- let + -- a = b + -- c = d + -- in foo + -- bar + -- baz + --or + -- let + -- a = b + -- c = d + -- in + -- fooooooooooooooooooo + let + noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 + ] + ] + addAlternative $ case indentPolicy of + IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyMultiple -> docLines noHangingBinds + IndentPolicyFree -> docLines + [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines bindDocs + ] + , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] + ] + addAlternative $ docLines + [ docNodeAnnKW lexpr (Just AnnLet) + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) + ] + _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] + -- docSeq [appSep $ docLit "let in", expDoc1] + HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of + DoExpr _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + MDoExpr _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x + | case x of + ListComp -> True + MonadComp -> True + _ -> False + -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq + $ List.intersperse docCommaSep + $ docForceSingleline + <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative + $ let + start = docCols + ColListComp + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack + "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1 : sM) = List.init stmtDocs + line1 = + docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + _ -> do + -- TODO + unknownNodeError "HsDo{} unknown stmtCtx" lexpr + ExplicitList _ _ elems@(_ : _) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr + hasComments <- hasAnyCommentsBelow lexpr + case splitFirstLast elemDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "[" + , docSeparator + , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e + ] + , docLit $ Text.pack "]" + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse + docCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) + ) + ++ [docLit $ Text.pack "]"] + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> docCols ColList [docCommaSep, d] + lineN = docCols + ColList + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ExplicitList _ _ [] -> docLit $ Text.pack "[]" + RecordCon _ lname fields -> case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- + fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression False indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just (L _ 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- + fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return (fieldl, lrdrNameToText lnameF, fExpDoc) + recordExpression True indentPolicy lexpr nameDoc fieldDocs + _ -> unknownNodeError "RecordCon with puns" lexpr + RecordUpd _ rExpr fields -> do + rExprDoc <- docSharedWrapper layoutExpr rExpr + rFs <- + fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ case ambName of + Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + recordExpression False indentPolicy lexpr rExprDoc rFs + ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do + expDoc <- docSharedWrapper layoutExpr exp1 + typDoc <- docSharedWrapper layoutType typ1 + docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] + ArithSeq _ Nothing info -> case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr + HsBracket{} -> do + -- TODO + briDocByExactInlineOnly "HsBracket{}" lexpr + HsRnBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsRnBracketOut{}" lexpr + HsTcBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsTcBracketOut{}" lexpr + HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do + allocateNode $ BDFPlain + (Text.pack + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]" + ) + HsSpliceE{} -> do + -- TODO + briDocByExactInlineOnly "HsSpliceE{}" lexpr + HsProc{} -> do + -- TODO + briDocByExactInlineOnly "HsProc{}" lexpr + HsStatic{} -> do + -- TODO + briDocByExactInlineOnly "HsStatic{}" lexpr + HsTick{} -> do + -- TODO + briDocByExactInlineOnly "HsTick{}" lexpr + HsBinTick{} -> do + -- TODO + briDocByExactInlineOnly "HsBinTick{}" lexpr + HsConLikeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsWrap{}" lexpr + ExplicitSum{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitSum{}" lexpr + HsPragE{} -> do + -- TODO + briDocByExactInlineOnly "HsPragE{}" lexpr + +recordExpression + :: (Data.Data.Data lExpr, Data.Data.Data name) + => Bool + -> IndentPolicy + -> GenLocated SrcSpan lExpr + -> ToBriDocM BriDocNumbered + -> [ ( GenLocated SrcSpan name + , Text + , Maybe (ToBriDocM BriDocNumbered) + ) + ] + -> ToBriDocM BriDocNumbered +recordExpression False _ lexpr nameDoc [] = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used + -- atm anyway. + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do + let (rF1f, rF1n, rF1e) = rF1 + runFilteredAlternative $ do + -- container { fieldA = blub, fieldB = blub } + addAlternative $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc + , appSep $ docLit $ Text.pack "{" + , docSeq $ List.intersperse docCommaSep $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr + , if dotdot + then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator + , docLit $ Text.pack "}" + ] + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc + , docSetBaseY + $ docLines + $ let + line1 = docCols + ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [appSep $ docLit $ Text.pack "=", docForceSingleline x] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> + docSeq [appSep $ docLit $ Text.pack "=", docForceSingleline x] + Nothing -> docEmpty + ] + dotdotLine = if dotdot + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing + $ docLines + $ let + line1 = docCols + ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + dotdotLine = if dotdot + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ) + +litBriDoc :: HsLit GhcPs -> BriDocFInt +litBriDoc = \case + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + _ -> error "litBriDoc: literal with no SourceText" + +overLitValBriDoc :: OverLitVal -> BriDocFInt +overLitValBriDoc = \case + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIsString (SourceText t) _ -> BDFLit $ Text.pack t + _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Brittany/Internal/Layouters/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Expr.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Layouters.Expr where + +import GHC.Hs +import 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/Brittany/Internal/Layouters/IE.hs b/source/library/Brittany/Internal/Layouters/IE.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/IE.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Layouters.IE where + +import qualified Data.List.Extra +import qualified Data.Text as Text +import GHC + ( AnnKeywordId(..) + , GenLocated(L) + , Located + , ModuleName + , moduleNameString + , unLoc + ) +import GHC.Hs +import qualified GHC.OldList as List +import Brittany.Internal.LayouterBasics +import Brittany.Internal.Prelude +import Brittany.Internal.Types +import Brittany.Internal.Utils + + + +prepareName :: LIEWrappedName name -> Located name +prepareName = ieLWrappedName + +layoutIE :: ToBriDoc IE +layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of + IEVar _ x -> layoutWrapped lie x + IEThingAbs _ x -> layoutWrapped lie x + IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] + IEThingWith _ x (IEWildcard _) _ _ -> + docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] + IEThingWith _ x _ ns _ -> do + hasComments <- orM + (hasCommentsBetween lie AnnOpenP AnnCloseP + : hasAnyCommentsBelow x + : map hasAnyCommentsBelow ns + ) + let sortedNs = List.sortOn wrappedNameToText ns + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [layoutWrapped lie x, docLit $ Text.pack "("] + ++ intersperse docCommaSep (map nameDoc sortedNs) + ++ [docParenR] + addAlternative + $ docWrapNodeRest lie + $ docAddBaseY BrIndentRegular + $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) + where + nameDoc = docLit <=< lrdrNameToTextAnn . prepareName + layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] + layoutItems FirstLastEmpty = docSetBaseY $ docLines + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] + , docParenR + ] + layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] + , docParenR + ] + layoutItems (FirstLast n1 nMs nN) = + docSetBaseY + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + ++ map layoutItem nMs + ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] + , docParenR + ] + IEModuleContents _ n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + where + layoutWrapped _ = \case + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEPattern n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "pattern " <> name + L _ (IEType n) -> do + name <- lrdrNameToTextAnn n + docLit $ Text.pack "type " <> name + +data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted +-- Helper function to deal with Located lists of LIEs. +-- In particular this will also associate documentation +-- from the located list that actually belongs to the last IE. +-- It also adds docCommaSep to all but the first element +-- This configuration allows both vertical and horizontal +-- handling of the resulting list. Adding parens is +-- left to the caller since that is context sensitive +layoutAnnAndSepLLIEs + :: SortItemsFlag + -> Located [LIE GhcPs] + -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do + let makeIENode ie = docSeq [docCommaSep, ie] + let + sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let + ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies + ieCommaDocs <- + docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of + FirstLastEmpty -> [] + FirstLastSingleton ie -> [ie] + FirstLast ie1 ieMs ieN -> + [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] + pure $ fmap pure ieCommaDocs -- returned shared nodes + where + mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] + mergeGroup [] = [] + mergeGroup items@[_] = items + mergeGroup items = if + | all isProperIEThing items -> [List.foldl1' thingFolder items] + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items + -- proper means that if it is a ThingWith, it does not contain a wildcard + -- (because I don't know what a wildcard means if it is not already a + -- IEThingAll). + isProperIEThing :: LIE GhcPs -> Bool + isProperIEThing = \case + L _ (IEThingAbs _ _wn) -> True + L _ (IEThingAll _ _wn) -> True + L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True + _ -> False + isIEVar :: LIE GhcPs -> Bool + isIEVar = \case + L _ IEVar{} -> True + _ -> False + thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs + thingFolder l1@(L _ IEVar{}) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 (L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) + = L + l + (IEThingWith + x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) + ) + thingFolder _ _ = + error "thingFolder should be exhaustive because we have a guard above" + + +-- Builds a complete layout for the given located +-- list of LIEs. The layout provides two alternatives: +-- (item, item, ..., item) +-- ( item +-- , item +-- ... +-- , item +-- ) +-- If the llies contains comments the list will +-- always expand over multiple lines, even when empty: +-- () -- no comments +-- ( -- a comment +-- ) +layoutLLIEs + :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline shouldSort llies = do + ieDs <- layoutAnnAndSepLLIEs shouldSort llies + hasComments <- hasAnyCommentsBelow llies + runFilteredAlternative $ case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" + addAlternativeCond hasComments $ docPar + (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + (ieDsH : ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + addAlternative + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +wrappedNameToText :: LIEWrappedName RdrName -> Text +wrappedNameToText = \case + L _ (IEName n) -> lrdrNameToText n + L _ (IEPattern n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +lieToText :: LIE GhcPs -> Text +lieToText = \case + L _ (IEVar _ wn) -> wrappedNameToText wn + L _ (IEThingAbs _ wn) -> wrappedNameToText wn + L _ (IEThingAll _ wn) -> wrappedNameToText wn + L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn + -- TODO: These _may_ appear in exports! + -- Need to check, and either put them at the top (for module) or do some + -- other clever thing. + L _ (IEModuleContents _ n) -> moduleNameToText n + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + where + moduleNameToText :: Located ModuleName -> Text + moduleNameToText (L _ name) = + Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Brittany/Internal/Layouters/Import.hs b/source/library/Brittany/Internal/Layouters/Import.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Import.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module 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 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 + + + +prepPkg :: SourceText -> String +prepPkg rawN = case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" +prepModName :: Located e -> e +prepModName = unLoc + +layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered +layoutImport importD = case importD of + ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do + importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + importAsCol <- + mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + compact = indentPolicy /= IndentPolicyFree + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies + minQLength = length "import qualified " + qLengthReal = + let + qualifiedPart = if q /= NotQualified then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = case src of + IsBoot -> length "{-# SOURCE #-} " + NotBoot -> 0 + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal + -- Cost in columns of importColumn + asCost = length "as " + hidingParenCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength + importQualifiers = docSeq + [ appSep $ docLit $ Text.pack "import" + , case src of + IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}" + NotBoot -> docEmpty + , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty + , if q /= NotQualified + then appSep $ docLit $ Text.pack "qualified" + else docEmpty + , maybe docEmpty (appSep . docLit) pkgNameT + ] + indentName = + if compact then id else docEnsureIndent (BrIndentSpecial qLength) + modNameD = indentName $ appSep $ docLit modNameT + hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 + hidDocColDiff = importCol - 2 - hidDocCol + hidDoc = + if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + importHead = docSeq [importQualifiers, modNameD] + bindingsD = case mllies of + Nothing -> docEmpty + Just (_, llies) -> do + hasComments <- hasAnyCommentsBelow llies + if compact + then docAlt + [ docSeq + [ hidDoc + , docForceSingleline $ layoutLLIEs True ShouldSortItems llies + ] + , let + makeParIfHiding = if hiding + then docAddBaseY BrIndentRegular . docPar hidDoc + else id + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + ] + else do + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq + [hidDoc, docParenLSep, docWrapNode llies docEmpty] + ) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + else docSeq + [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + -- ..[hiding].( b + -- , b' + -- ) + (ieD : ieDs') -> docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] + ) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) + makeAsDoc asT = + docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] + if compact + then + let asDoc = maybe docEmpty makeAsDoc masT + in + docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular + $ docPar (docSeq [importHead, asDoc]) bindingsD + ] + else case masT of + Just n -> if enoughRoom + then docLines [docSeq [importHead, asDoc], bindingsD] + else docLines [importHead, asDoc, bindingsD] + where + enoughRoom = nameCost < importAsCol - asCost + asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) + $ makeAsDoc n + Nothing -> if enoughRoom + then docSeq [importHead, bindingsD] + else docLines [importHead, bindingsD] + where enoughRoom = nameCost < importCol - hidingParenCost + _ -> docEmpty diff --git a/source/library/Brittany/Internal/Layouters/Module.hs b/source/library/Brittany/Internal/Layouters/Module.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Module.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Layouters.Module where + +import qualified Data.Maybe +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) +import GHC.Hs +import qualified GHC.OldList as List +import 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) + + + +layoutModule :: ToBriDoc' HsModule +layoutModule lmod@(L _ mod') = case mod' of + -- Implicit module Main + HsModule _ Nothing _ imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) + -- sortedImports <- sortImports imports + -- docLines $ [layoutImport y i | (y, i) <- sortedImports] + HsModule _ (Just n) les imports _ _ _ -> do + commentedImports <- transformToCommentedImport imports + -- groupify commentedImports `forM_` tellDebugMessShow + -- sortedImports <- sortImports imports + let tn = Text.pack $ moduleNameString $ unLoc n + allowSingleLineExportList <- + mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack + -- the config should not prevent single-line layout when there is no + -- export list + let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les + docLines + $ docSeq + [ docNodeAnnKW lmod Nothing docEmpty + -- A pseudo node that serves merely to force documentation + -- before the node + , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do + addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + addAlternative $ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) + (docSeq + [ docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + ) + ] + ] + : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] + +data CommentedImport + = EmptyLine + | IndependentComment (Comment, DeltaPos) + | ImportStatement ImportStatementRecord + +instance Show CommentedImport where + show = \case + EmptyLine -> "EmptyLine" + IndependentComment _ -> "IndependentComment" + ImportStatement r -> + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +data ImportStatementRecord = ImportStatementRecord + { commentsBefore :: [(Comment, DeltaPos)] + , commentsAfter :: [(Comment, DeltaPos)] + , importStatement :: ImportDecl GhcPs + } + +instance Show ImportStatementRecord where + show r = + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +transformToCommentedImport + :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] +transformToCommentedImport is = do + nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do + annotionMay <- astAnn i + pure (annotionMay, rawImport) + let + convertComment (c, DP (y, x)) = + replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] + accumF + :: [(Comment, DeltaPos)] + -> (Maybe Annotation, ImportDecl GhcPs) + -> ([(Comment, DeltaPos)], [CommentedImport]) + accumF accConnectedComm (annMay, decl) = case annMay of + Nothing -> + ( [] + , [ ImportStatement ImportStatementRecord + { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } + ] + ) + Just ann -> + let + blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 + (newAccumulator, priorComments') = + List.span ((== 0) . deltaRow . snd) (annPriorComments ann) + go + :: [(Comment, DeltaPos)] + -> [(Comment, DeltaPos)] + -> ([CommentedImport], [(Comment, DeltaPos)], Int) + go acc [] = ([], acc, 0) + go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) + go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs + go acc ((c1, DP (y, x)) : xs) = + ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine + , (c1, DP (1, x)) : acc + , 0 + ) + (convertedIndependentComments, beforeComments, initialBlanks) = + if blanksBeforeImportDecl /= 0 + then (convertComment =<< priorComments', [], 0) + else go [] (reverse priorComments') + in + ( newAccumulator + , convertedIndependentComments + ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine + ++ [ ImportStatement ImportStatementRecord + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm + , importStatement = decl + } + ] + ) + let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations + pure $ join $ (convertComment =<< finalAcc) : finalList + +sortCommentedImports :: [CommentedImport] -> [CommentedImport] +sortCommentedImports = + unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify + where + unpackImports :: [CommentedImport] -> [CommentedImport] + unpackImports xs = xs >>= \case + l@EmptyLine -> [l] + l@IndependentComment{} -> [l] + ImportStatement r -> + map IndependentComment (commentsBefore r) ++ [ImportStatement r] + mergeGroups + :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] + mergeGroups xs = xs >>= \case + Left x -> [x] + Right y -> ImportStatement <$> y + sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] + sortGroups = + List.sortOn (moduleNameString . unLoc . ideclName . importStatement) + groupify + :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] + groupify cs = go [] cs + where + go [] = \case + (l@EmptyLine : rest) -> Left l : go [] rest + (l@IndependentComment{} : rest) -> Left l : go [] rest + (ImportStatement r : rest) -> go [r] rest + [] -> [] + go acc = \case + (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest + (l@IndependentComment{} : rest) -> + Left l : Right (reverse acc) : go [] rest + (ImportStatement r : rest) -> go (r : acc) rest + [] -> [Right (reverse acc)] + +commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered +commentedImportsToDoc = \case + EmptyLine -> docLitS "" + IndependentComment c -> commentToDoc c + ImportStatement r -> docSeq + (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) + where + commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Brittany/Internal/Layouters/Pattern.hs b/source/library/Brittany/Internal/Layouters/Pattern.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Pattern.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Layouters.Pattern where + +import qualified Data.Foldable as Foldable +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import GHC (GenLocated(L), ol_val) +import GHC.Hs +import qualified GHC.OldList as List +import GHC.Types.Basic +import 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 + + + +-- | layouts patterns (inside function bindings, case alternatives, let +-- bindings or do notation). E.g. for input +-- > case computation of +-- > (warnings, Success a b) -> .. +-- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by +-- 'layoutPat'. Similarly for +-- > func abc True 0 = [] +-- ^^^^^^^^^^ this part +-- We will use `case .. of` as the imagined prefix to the examples used in +-- the different cases below. +layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) +layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + -- _ -> expr + VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n + -- abc -> expr + LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit + -- 0 -> expr + ParPat _ inner -> do + -- (nestedpat) -> expr + left <- docLit $ Text.pack "(" + right <- docLit $ Text.pack ")" + innerDocs <- colsWrapPat =<< layoutPat inner + return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right + -- return $ (left Seq.<| innerDocs) Seq.|> right + -- case Seq.viewl innerDocs of + -- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur.. + -- x1 Seq.:< rest -> case Seq.viewr rest of + -- Seq.EmptyR -> + -- fmap return $ docSeq + -- [ docLit $ Text.pack "(" + -- , return x1 + -- , docLit $ Text.pack ")" + -- ] + -- middle Seq.:> xN -> do + -- x1' <- docSeq [docLit $ Text.pack "(", return x1] + -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] + -- return $ (x1' Seq.<| middle) Seq.|> xN' + ConPat _ lname (PrefixCon args) -> do + -- Abc a b c -> expr + nameDoc <- lrdrNameToTextAnn lname + argDocs <- layoutPat `mapM` args + if null argDocs + then return <$> docLit nameDoc + else do + x1 <- appSep (docLit nameDoc) + xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap + colsWrapPat + argDocs + return $ x1 Seq.<| xR + ConPat _ lname (InfixCon left right) -> do + -- a :< b -> expr + nameDoc <- lrdrNameToTextAnn lname + leftDoc <- appSep . colsWrapPat =<< layoutPat left + rightDoc <- colsWrapPat =<< layoutPat right + middle <- appSep $ docLit nameDoc + return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc + ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do + -- Abc{} -> expr + let t = lrdrNameToText lname + fmap Seq.singleton $ docLit $ t <> Text.pack "{}" + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do + -- Abc { a = locA, b = locB, c = locC } -> expr1 + -- Abc { a, b, c } -> expr2 + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ List.intersperse docCommaSep $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName + , docSeparator + , docLit $ Text.pack "}" + ] + ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do + -- Abc { .. } -> expr + let t = lrdrNameToText lname + Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"] + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) + | dotdoti == length fs -> do + -- Abc { a = locA, .. } + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case + (fieldName, Just fieldDoc) -> + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + , docCommaSep + ] + (fieldName, Nothing) -> [docLit fieldName, docCommaSep] + , docLit $ Text.pack "..}" + ] + TuplePat _ args boxity -> do + -- (nestedpat1, nestedpat2, nestedpat3) -> expr + -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr + case boxity of + Boxed -> wrapPatListy args "()" docParenL docParenR + Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep + AsPat _ asName asPat -> do + -- bind@nestedpat -> expr + wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") + SigPat _ pat1 (HsPS _ ty1) -> do + -- i :: Int -> expr + patDocs <- layoutPat pat1 + tyDoc <- docSharedWrapper layoutType ty1 + case Seq.viewr patDocs of + Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" + xR Seq.:> xN -> do + xN' <- -- at the moment, we don't support splitting patterns into + -- multiple lines. but we cannot enforce pasting everything + -- into one line either, because the type signature will ignore + -- this if we overflow sufficiently. + -- In order to prevent syntactically invalid results in such + -- cases, we need the AddBaseY here. + -- This can all change when patterns get multiline support. + docAddBaseY BrIndentRegular $ docSeq + [ appSep $ return xN + , appSep $ docLit $ Text.pack "::" + , docForceSingleline tyDoc + ] + return $ xR Seq.|> xN' + ListPat _ elems -> + -- [] -> expr1 + -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 + wrapPatListy elems "[]" docBracketL docBracketR + BangPat _ pat1 -> do + -- !nestedpat -> expr + wrapPatPrepend pat1 (docLit $ Text.pack "!") + LazyPat _ pat1 -> do + -- ~nestedpat -> expr + wrapPatPrepend pat1 (docLit $ Text.pack "~") + NPat _ llit@(L _ ol) mNegative _ -> do + -- -13 -> expr + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol + negDoc <- docLit $ Text.pack "-" + pure $ case mNegative of + Just{} -> Seq.fromList [negDoc, litDoc] + Nothing -> Seq.singleton litDoc + + _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat + +colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered +colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList + +wrapPatPrepend + :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR + +wrapPatListy + :: [LPat GhcPs] + -> String + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + -> ToBriDocM (Seq BriDocNumbered) +wrapPatListy elems both start end = do + elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) + case Seq.viewl elemDocs of + Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both + x1 Seq.:< rest -> do + sDoc <- start + eDoc <- end + rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd] + return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Brittany/Internal/Layouters/Stmt.hs b/source/library/Brittany/Internal/Layouters/Stmt.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Stmt.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 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 + + + +layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) +layoutStmt lstmt@(L _ stmt) = do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentAmount :: Int <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + docWrapNode lstmt $ case stmt of + LastStmt _ body Nothing _ -> do + layoutExpr body + BindStmt _ lPat expr -> do + patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat + expDoc <- docSharedWrapper layoutExpr expr + docAlt + [ docCols + ColBindStmt + [ appSep patDoc + , docSeq + [ appSep $ docLit $ Text.pack "<-" + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc + ] + ] + , docCols + ColBindStmt + [ appSep patDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "<-") (expDoc) + ] + ] + LetStmt _ binds -> do + let isFree = indentPolicy == IndentPolicyFree + let indentFourPlus = indentAmount >= 4 + layoutLocalBinds binds >>= \case + Nothing -> docLit $ Text.pack "let" + -- i just tested the above, and it is indeed allowed. heh. + Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [bindDoc] -> docAlt + [ -- let bind = expr + docCols + ColDoLet + [ appSep $ docLit $ Text.pack "let" + , let + f = case indentPolicy of + IndentPolicyFree -> docSetBaseAndIndent + IndentPolicyLeft -> docForceSingleline + IndentPolicyMultiple + | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc + ] + , -- let + -- bind = expr + docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) + ] + Just bindDocs -> runFilteredAlternative $ do + -- let aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (isFree || indentFourPlus) $ docSeq + [ appSep $ docLit $ Text.pack "let" + , let + f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs + ] + -- let + -- aaa = expra + -- bbb = exprb + -- ccc = exprc + addAlternativeCond (not indentFourPlus) + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do + -- rec stmt1 + -- stmt2 + -- stmt3 + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts + ] + -- rec + -- stmt1 + -- stmt2 + -- stmt3 + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docLit (Text.pack "rec")) + (docLines $ layoutStmt <$> stmts) + BodyStmt _ expr _ _ -> do + expDoc <- docSharedWrapper layoutExpr expr + docAddBaseY BrIndentRegular $ expDoc + _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/source/library/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Brittany/Internal/Layouters/Stmt.hs-boot new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Stmt.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Layouters.Stmt where + +import GHC.Hs +import Brittany.Internal.Types + + + +layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Brittany/Internal/Layouters/Type.hs b/source/library/Brittany/Internal/Layouters/Type.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Layouters/Type.hs @@ -0,0 +1,635 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module 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 Brittany.Internal.LayouterBasics +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils + (FirstLastView(..), splitFirstLast) + + + +layoutType :: ToBriDoc HsType +layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of + -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" + HsTyVar _ promoted name -> do + t <- lrdrNameToTextAnnTypeEqualityIsSpecial name + case promoted of + IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] + NotPromoted -> docWrapNode name $ docLit t + HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do + let bndrs = getBinders hsf + typeDoc <- docSharedWrapper layoutType typ2 + tyVarDocs <- layoutTyVarBndrs bndrs + cntxtDocs <- cntxts `forM` docSharedWrapper layoutType + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + let + tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs + forallDoc = docAlt + [ let open = docLit $ Text.pack "forall" + in docSeq ([open] ++ tyVarDocLineList) + , docPar + (docLit (Text.pack "forall")) + (docLines $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" + ] + ) + ] + contextDoc = case cntxtDocs of + [] -> docLit $ Text.pack "()" + [x] -> x + _ -> docAlt + [ let + open = docLit $ Text.pack "(" + close = docLit $ Text.pack ")" + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) + , let + open = docCols + ColTyOpPrefix + [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] + close = docLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] + in docPar open $ docLines $ list ++ [close] + ] + docAlt + -- :: forall a b c . (Foo a b c) => a b -> c + [ docSeq + [ if null bndrs + then docEmpty + else + let + open = docLit $ Text.pack "forall" + close = docLit $ Text.pack " . " + in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) + , docForceSingleline contextDoc + , docLit $ Text.pack " => " + , docForceSingleline typeDoc + ] + -- :: forall a b c + -- . (Foo a b c) + -- => a b + -- -> c + , docPar + forallDoc + (docLines + [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) $ contextDoc + ] + , docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] + ] + ) + ] + HsForAllTy _ hsf typ2 -> do + let bndrs = getBinders hsf + typeDoc <- layoutType typ2 + tyVarDocs <- layoutTyVarBndrs bndrs + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs + docAlt + -- forall x . x + [ docSeq + [ if null bndrs + then docEmpty + else + let + open = docLit $ Text.pack "forall" + close = docLit $ Text.pack " . " + in docSeq ([open] ++ tyVarDocLineList ++ [close]) + , docForceSingleline $ return $ typeDoc + ] + -- :: forall x + -- . x + , docPar + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ) + -- :: forall + -- (x :: *) + -- . x + , docPar + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> + docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" + ] + ) + ++ [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ] + ) + ] + HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do + typeDoc <- docSharedWrapper layoutType typ1 + cntxtDocs <- cntxts `forM` docSharedWrapper layoutType + let + contextDoc = docWrapNode lcntxts $ case cntxtDocs of + [] -> docLit $ Text.pack "()" + [x] -> x + _ -> docAlt + [ let + open = docLit $ Text.pack "(" + close = docLit $ Text.pack ")" + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) + , let + open = docCols + ColTyOpPrefix + [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] + close = docLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] + in docPar open $ docLines $ list ++ [close] + ] + let + maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + docAlt + -- (Foo a b c) => a b -> c + [ docSeq + [ docForceSingleline contextDoc + , docLit $ Text.pack " => " + , docForceSingleline typeDoc + ] + -- (Foo a b c) + -- => a b + -- -> c + , docPar + (docForceSingleline contextDoc) + (docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) + ] + HsFunTy _ _ typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + hasComments <- hasAnyCommentsBelow ltype + docAlt + $ [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 + ] + | not hasComments + ] + ++ [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 + ] + ) + ] + HsParTy _ typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack "(" + , docForceSingleline typeDoc1 + , docLit $ Text.pack ")" + ] + , docPar + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack ")") + ] + HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do + let + gather + :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 + final -> (final, list) + let (typHead, typRest) = gather [typ2] typ1 + docHead <- docSharedWrapper layoutType typHead + docRest <- docSharedWrapper layoutType `mapM` typRest + docAlt + [ docSeq + $ docForceSingleline docHead + : (docRest >>= \d -> [docSeparator, docForceSingleline d]) + , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) + ] + HsAppTy _ typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + docAlt + [ docSeq + [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2] + , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) + ] + HsListTy _ typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack "[" + , docForceSingleline typeDoc1 + , docLit $ Text.pack "]" + ] + , docPar + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack "]") + ] + HsTupleTy _ tupleSort typs -> case tupleSort of + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple + HsBoxedOrConstraintTuple -> simple + where + unboxed = if null typs + then error "brittany internal error: unboxed unit" + else unboxedL + simple = if null typs then unitL else simpleL + unitL = docLit $ Text.pack "()" + simpleL = do + docs <- docSharedWrapper layoutType `mapM` typs + let + end = docLit $ Text.pack ")" + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) + docAlt + [ docSeq + $ [docLit $ Text.pack "("] + ++ docWrapNodeRest ltype commaDocs + ++ [end] + , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] + in + docPar + (docAddBaseY (BrIndentSpecial 2) $ line1) + (docLines $ docWrapNodeRest ltype lines ++ [end]) + ] + unboxedL = do + docs <- docSharedWrapper layoutType `mapM` typs + let + start = docParenHashLSep + end = docParenHashRSep + docAlt + [ docSeq + $ [start] + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) + ++ [end] + , let + line1 = docCols ColTyOpPrefix [start, head docs] + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + in docPar + (docAddBaseY (BrIndentSpecial 2) line1) + (docLines $ lines ++ [end]) + ] + HsOpTy{} -> -- TODO + briDocByExactInlineOnly "HsOpTy{}" ltype + -- HsOpTy typ1 opName typ2 -> do + -- -- TODO: these need some proper fixing. precedences don't add up. + -- -- maybe the parser just returns some trivial right recursion + -- -- parse result for any type level operators. + -- -- need to check how things are handled on the expression level. + -- let opStr = lrdrNameToText opName + -- let opLen = Text.length opStr + -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 + -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 + -- let line = do -- Maybe + -- l1 <- _ldesc_line desc1 + -- l2 <- _ldesc_line desc2 + -- let len1 = _lColumns_min l1 + -- let len2 = _lColumns_min l2 + -- let len = 2 + opLen + len1 + len2 + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol1 <- descToBlockStart desc1 + -- (min2, max2) <- descToMinMax (1+opLen) desc2 + -- let (minR, maxR) = case descToBlockMinMax desc1 of + -- Nothing -> (min2, max2) + -- Just (min1, max1) -> (max min1 min2, max max1 max2) + -- return $ BlockDesc + -- { _bdesc_blockStart = rol1 + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Just (1+opLen) + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \params -> do + -- remaining <- getCurRemaining + -- let allowSameLine = _params_sepLines params /= SepLineTypeOp + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do + -- applyLayouterRestore layouter1 defaultParams + -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " + -- applyLayouterRestore layouter2 defaultParams + -- _ -> do + -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params + -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 + -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams + -- layoutWriteNewline + -- layoutWriteAppend $ opStr <> Text.pack " " + -- layoutWriteEnsureBlockPlusN downIndent + -- applyLayouterRestore layouter2 defaultParams + -- { _params_sepLines = SepLineTypeOp + -- , _params_opIndent = Just downIndent + -- } + -- , _layouter_ast = ltype + -- } + HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack + ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + , docForceSingleline typeDoc1 + ] + , docPar + (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ] + ) + ] + -- TODO: test KindSig + HsKindSig _ typ1 kind1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + kindDoc1 <- docSharedWrapper layoutType kind1 + hasParens <- hasAnnKeyword ltype AnnOpenP + docAlt + [ if hasParens + then docSeq + [ docLit $ Text.pack "(" + , docForceSingleline typeDoc1 + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , docForceSingleline kindDoc1 + , docLit $ Text.pack ")" + ] + else docSeq + [ docForceSingleline typeDoc1 + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , docForceSingleline kindDoc1 + ] + , if hasParens + then docLines + [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 3) $ typeDoc1 + ] + , docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ] + , (docLit $ Text.pack ")") + ] + else docPar + typeDoc1 + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ] + ) + ] + HsBangTy{} -> -- TODO + briDocByExactInlineOnly "HsBangTy{}" ltype + -- HsBangTy bang typ1 -> do + -- let bangStr = case bang of + -- HsSrcBang _ unpackness strictness -> + -- (++) + -- (case unpackness of + -- SrcUnpack -> "{-# UNPACK -#} " + -- SrcNoUnpack -> "{-# NOUNPACK -#} " + -- NoSrcUnpack -> "" + -- ) + -- (case strictness of + -- SrcLazy -> "~" + -- SrcStrict -> "!" + -- NoSrcStrict -> "" + -- ) + -- let bangLen = length bangStr + -- layouter@(Layouter desc _ _) <- layoutType typ1 + -- let line = do -- Maybe + -- l <- _ldesc_line desc + -- let len = bangLen + _lColumns_min l + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol <- descToBlockStart desc + -- (minR,maxR) <- descToBlockMinMax desc + -- return $ BlockDesc + -- { _bdesc_blockStart = rol + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Nothing + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \_params -> do + -- remaining <- getCurRemaining + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- applyLayouterRestore layouter defaultParams + -- _ -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- layoutWritePostCommentsRestore ltype + -- applyLayouterRestore layouter defaultParams + -- , _layouter_ast = ltype + -- } + HsSpliceTy{} -> -- TODO + briDocByExactInlineOnly "HsSpliceTy{}" ltype + HsDocTy{} -> -- TODO + briDocByExactInlineOnly "HsDocTy{}" ltype + HsRecTy{} -> -- TODO + briDocByExactInlineOnly "HsRecTy{}" ltype + HsExplicitListTy _ _ typs -> do + typDocs <- docSharedWrapper layoutType `mapM` typs + hasComments <- hasAnyCommentsBelow ltype + let specialCommaSep = appSep $ docLit $ Text.pack " ," + docAlt + [ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) + ++ [docLit $ Text.pack "]"] + , case splitFirstLast typDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "'[" + , docSeparator + , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e + ] + , docLit $ Text.pack " ]" + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse + specialCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) + ) + ++ [docLit $ Text.pack " ]"] + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] + lineN = docCols + ColList + [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ] + HsExplicitTupleTy{} -> -- TODO + briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype + HsTyLit _ lit -> case lit of + HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsNumTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsStrTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsWildCardTy _ -> docLit $ Text.pack "_" + HsSumTy{} -> -- TODO + briDocByExactInlineOnly "HsSumTy{}" ltype + HsStarTy _ isUnicode -> do + if isUnicode + then docLit $ Text.pack "\x2605" -- Unicode star + else docLit $ Text.pack "*" + XHsType{} -> error "brittany internal error: XHsType" + HsAppKindTy _ ty kind -> do + t <- docSharedWrapper layoutType ty + k <- docSharedWrapper layoutType kind + docAlt + [ docSeq + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar t (docSeq [docLit $ Text.pack "@", k]) + ] + +layoutTyVarBndrs + :: [LHsTyVarBndr () GhcPs] + -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] +layoutTyVarBndrs = mapM $ \case + (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ _ lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + +-- there is no specific reason this returns a list instead of a single +-- BriDoc node. +processTyVarBndrsSingleline + :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] +processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case + (tname, Nothing) -> [docSeparator, docLit tname] + (tname, Just doc) -> + [ docSeparator + , docLit $ Text.pack "(" <> tname <> Text.pack " :: " + , docForceSingleline $ doc + , docLit $ Text.pack ")" + ] + +getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] +getBinders x = case x of + HsForAllVis _ b -> b + HsForAllInvis _ b -> fmap withoutSpecificity b + XHsForAllTelescope _ -> [] + +withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass +withoutSpecificity = fmap $ \case + UserTyVar a _ c -> UserTyVar a () c + KindedTyVar a _ c d -> KindedTyVar a () c d + XTyVarBndr a -> XTyVarBndr a diff --git a/source/library/Brittany/Internal/Obfuscation.hs b/source/library/Brittany/Internal/Obfuscation.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Obfuscation.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +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 Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import System.Random + + + +obfuscate :: Text -> IO Text +obfuscate input = do + let predi x = isAlphaNum x || x `elem` "_'" + let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) + let idents = Set.toList $ Set.fromList $ filter (all predi) groups + let + exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x + let filtered = filter exceptionFilter idents + mappings <- fmap Map.fromList $ filtered `forM` \x -> do + r <- createAlias x + pure (x, r) + let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings) + pure $ Text.concat $ fmap Text.pack groups' + +keywords :: [String] +keywords = + [ "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "mdo" + , "else" + , "forall" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "qualified" + , "then" + , "type" + , "where" + , "_" + , "foreign" + , "ccall" + , "as" + , "safe" + , "unsafe" + , "hiding" + , "proc" + , "rec" + , "family" + ] + +extraKWs :: [String] +extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] + +createAlias :: String -> IO String +createAlias xs = go NoHint xs + where + go _hint "" = pure "" + go hint (c : cr) = do + c' <- case hint of + VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] + VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c + cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr + pure (c' : cr') + +data Hint = NoHint | VocalHint | NoVocalHint + +_randomRange :: Random a => a -> a -> IO a +_randomRange lo hi = do + gen <- getStdGen + let (x, gen') = randomR (lo, hi) gen + setStdGen gen' + pure x + +randomFrom :: [a] -> IO a +randomFrom l = do + let hi = length l - 1 + gen <- getStdGen + let (x, gen') = randomR (0, hi) gen + setStdGen gen' + pure $ l List.!! x diff --git a/source/library/Brittany/Internal/ParseModule.hs b/source/library/Brittany/Internal/ParseModule.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/ParseModule.hs @@ -0,0 +1,316 @@ +{-# OPTIONS_GHC -Wno-implicit-prelude #-} + +module 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 GHC +import qualified GHC.ByteOrder +import qualified GHC.Data.Bag +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.SrcLoc +import qualified GHC.Utils.Error +import qualified GHC.Utils.Fingerprint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint + +-- | Parses a Haskell module. Although this nominally requires IO, it is +-- morally pure. It should have no observable effects. +parseModule + :: IO.MonadIO io + => [String] + -> FilePath + -> (GHC.Driver.Session.DynFlags -> io (Either String a)) + -> String + -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do + let + dynFlags1 = GHC.Driver.Session.gopt_set + -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both + -- of those modes have trouble parsing safe imports (@import safe ...@). + -- Neither passing in @"-XUnsafe"@ as a command line argument nor having + -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. + initialDynFlags + { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe + } + GHC.Driver.Session.Opt_KeepRawTokenStream + (dynFlags2, leftovers1, _) <- + GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 + $ fmap GHC.Types.SrcLoc.noLoc arguments1 + handleLeftovers leftovers1 + let + stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string + arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath + (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma + dynFlags2 + arguments2 + handleLeftovers leftovers2 + dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 + let + parseResult = + ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string + case parseResult of + Left errorMessages -> handleErrorMessages errorMessages + Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) + +handleLeftovers + :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () +handleLeftovers leftovers = + Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show + (fmap GHC.Types.SrcLoc.unLoc leftovers) + +handleErrorMessages + :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a +handleErrorMessages = + Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList + +initialDynFlags :: GHC.Driver.Session.DynFlags +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 +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 = "" + } + +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 +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 + } + +initialTargetPlatform :: GHC.Settings.Platform +initialTargetPlatform = GHC.Settings.Platform + { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian + , GHC.Settings.platformHasGnuNonexecStack = False + , GHC.Settings.platformHasIdentDirective = False + , GHC.Settings.platformHasSubsectionsViaSymbols = False + , GHC.Settings.platformIsCrossCompiling = False + , GHC.Settings.platformLeadingUnderscore = False + , GHC.Settings.platformMini = initialPlatformMini + , GHC.Settings.platformTablesNextToCode = False + , GHC.Settings.platformUnregisterised = False + , GHC.Settings.platformWordSize = GHC.Platform.PW8 + } + +initialToolSettings :: GHC.Settings.ToolSettings +initialToolSettings = GHC.Settings.ToolSettings + { GHC.Settings.toolSettings_ccSupportsNoPie = False + , GHC.Settings.toolSettings_extraGccViaCFlags = [] + , GHC.Settings.toolSettings_ldIsGnuLd = False + , GHC.Settings.toolSettings_ldSupportsBuildId = False + , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False + , GHC.Settings.toolSettings_ldSupportsFilelist = False + , GHC.Settings.toolSettings_opt_a = [] + , GHC.Settings.toolSettings_opt_c = [] + , GHC.Settings.toolSettings_opt_cxx = [] + , GHC.Settings.toolSettings_opt_F = [] + , GHC.Settings.toolSettings_opt_i = [] + , GHC.Settings.toolSettings_opt_l = [] + , GHC.Settings.toolSettings_opt_L = [] + , GHC.Settings.toolSettings_opt_lc = [] + , GHC.Settings.toolSettings_opt_lcc = [] + , GHC.Settings.toolSettings_opt_lm = [] + , GHC.Settings.toolSettings_opt_lo = [] + , GHC.Settings.toolSettings_opt_P = [] + , GHC.Settings.toolSettings_opt_P_fingerprint = + GHC.Utils.Fingerprint.fingerprint0 + , GHC.Settings.toolSettings_opt_windres = [] + , GHC.Settings.toolSettings_pgm_a = ("", []) + , GHC.Settings.toolSettings_pgm_ar = "" + , GHC.Settings.toolSettings_pgm_c = "" + , GHC.Settings.toolSettings_pgm_dll = ("", []) + , GHC.Settings.toolSettings_pgm_F = "" + , GHC.Settings.toolSettings_pgm_i = "" + , GHC.Settings.toolSettings_pgm_install_name_tool = "" + , GHC.Settings.toolSettings_pgm_l = ("", []) + , GHC.Settings.toolSettings_pgm_L = "" + , GHC.Settings.toolSettings_pgm_lc = ("", []) + , GHC.Settings.toolSettings_pgm_lcc = ("", []) + , GHC.Settings.toolSettings_pgm_libtool = "" + , GHC.Settings.toolSettings_pgm_lm = ("", []) + , GHC.Settings.toolSettings_pgm_lo = ("", []) + , GHC.Settings.toolSettings_pgm_otool = "" + , GHC.Settings.toolSettings_pgm_P = ("", []) + , GHC.Settings.toolSettings_pgm_ranlib = "" + , GHC.Settings.toolSettings_pgm_T = "" + , GHC.Settings.toolSettings_pgm_windres = "" + } diff --git a/source/library/Brittany/Internal/Prelude.hs b/source/library/Brittany/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Prelude.hs @@ -0,0 +1,194 @@ +module Brittany.Internal.Prelude + ( module E + ) where + +import Control.Applicative as E (Alternative(..), Applicative(..)) +import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) +import Control.Concurrent as E (forkIO, forkOS, threadDelay) +import Control.Concurrent.Chan as E (Chan) +import Control.Concurrent.MVar as E + (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) +import Control.Exception as E (assert, bracket, evaluate) +import Control.Monad as E + ( (<$!>) + , (<=<) + , (=<<) + , (>=>) + , Functor(..) + , Monad(..) + , MonadPlus(..) + , filterM + , forM + , forM_ + , forever + , guard + , join + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , mapM + , mapM_ + , replicateM + , replicateM_ + , sequence + , sequence_ + , unless + , void + , when + ) +import Control.Monad.Extra as E + (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) +import Control.Monad.IO.Class as E (MonadIO(..)) +import Control.Monad.ST as E (ST) +import Control.Monad.Trans.Class as E (lift) +import Control.Monad.Trans.Maybe as E (MaybeT(..)) +import Control.Monad.Trans.MultiRWS as E + (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) +import Data.Bifunctor as E (bimap) +import Data.Bool as E (Bool(..)) +import Data.Char as E (Char, chr, ord) +import Data.Data as E (toConstr) +import Data.Either as E (Either(..), either) +import Data.Foldable as E (asum, fold, foldl', foldr') +import Data.Function as E ((&), fix) +import Data.Functor as E (($>)) +import Data.Functor.Identity as E (Identity(..)) +import Data.IORef as E (IORef) +import Data.Int as E (Int) +import Data.List as E + ( all + , break + , drop + , dropWhile + , elem + , filter + , find + , intercalate + , intersperse + , isPrefixOf + , isSuffixOf + , iterate + , length + , mapAccumL + , mapAccumR + , maximum + , minimum + , notElem + , nub + , null + , partition + , repeat + , replicate + , sortBy + , sum + , take + , takeWhile + , transpose + , uncons + , unzip + , zip + , zip3 + , zipWith + ) +import Data.List.Extra as E (nubOrd, stripSuffix) +import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) +import Data.Map as E (Map) +import Data.Maybe as E + (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) +import Data.Monoid as E + ( All(..) + , Alt(..) + , Any(..) + , Endo(..) + , Monoid(..) + , Product(..) + , Sum(..) + , mconcat + ) +import Data.Ord as E (Down(..), Ordering(..), comparing) +import Data.Proxy as E (Proxy(..)) +import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) +import Data.Semigroup as E ((<>), Semigroup(..)) +import Data.Sequence as E (Seq) +import Data.Set as E (Set) +import Data.String as E (String) +import Data.Text as E (Text) +import Data.Tree as E (Tree(..)) +import Data.Tuple as E (swap) +import Data.Typeable as E (Typeable) +import Data.Version as E (showVersion) +import Data.Void as E (Void) +import Data.Word as E (Word, Word32) +import Debug.Trace as E + ( trace + , traceIO + , traceId + , traceM + , traceShow + , traceShowId + , traceShowM + , traceStack + ) +import Foreign.ForeignPtr as E (ForeignPtr) +import Foreign.Storable as E (Storable) +import GHC.Exts as E (Constraint) +import GHC.Hs.Extension as E (GhcPs) +import GHC.Types.Name.Reader as E (RdrName) +import Prelude as E + ( ($) + , ($!) + , (&&) + , (++) + , (.) + , (<$>) + , Bounded(..) + , Double + , Enum(..) + , Eq(..) + , Float + , Floating(..) + , Foldable + , Fractional(..) + , Integer + , Integral(..) + , Num(..) + , Ord(..) + , RealFloat(..) + , RealFrac(..) + , Show(..) + , Traversable + , (^) + , and + , any + , const + , curry + , error + , flip + , foldl + , foldr + , foldr1 + , fromIntegral + , fst + , head + , id + , map + , not + , or + , otherwise + , print + , putStr + , putStrLn + , realToFrac + , reverse + , seq + , snd + , subtract + , traverse + , uncurry + , undefined + , (||) + ) +import System.IO as E (IO, hFlush, stdout) +import Text.Read as E (readMaybe) diff --git a/source/library/Brittany/Internal/PreludeUtils.hs b/source/library/Brittany/Internal/PreludeUtils.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/PreludeUtils.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Brittany.Internal.PreludeUtils where + +import Control.Applicative +import Control.DeepSeq (NFData, force) +import Control.Exception.Base (evaluate) +import Control.Monad +import qualified Data.Strict.Maybe as Strict +import Debug.Trace +import Prelude +import System.IO + + + +instance Applicative Strict.Maybe where + pure = Strict.Just + Strict.Just f <*> Strict.Just x = Strict.Just (f x) + _ <*> _ = Strict.Nothing + +instance Monad Strict.Maybe where + Strict.Nothing >>= _ = Strict.Nothing + Strict.Just x >>= f = f x + +instance Alternative Strict.Maybe where + empty = Strict.Nothing + x <|> Strict.Nothing = x + _ <|> x = x + +traceFunctionWith + :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +traceFunctionWith name s1 s2 f x = trace traceStr y + where + y = f x + traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y + +(<&!>) :: Monad m => m a -> (a -> b) -> m b +(<&!>) = flip (<$!>) + +putStrErrLn :: String -> IO () +putStrErrLn s = hPutStrLn stderr s + +putStrErr :: String -> IO () +putStrErr s = hPutStr stderr s + +printErr :: Show a => a -> IO () +printErr = putStrErrLn . show + +errorIf :: Bool -> a -> a +errorIf False = id +errorIf True = error "errorIf" + +errorIfNote :: Maybe String -> a -> a +errorIfNote Nothing = id +errorIfNote (Just x) = error x + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap +infixl 4 <&> + +(.>) :: (a -> b) -> (b -> c) -> (a -> c) +f .> g = g . f +infixl 9 .> + +evaluateDeep :: NFData a => a -> IO a +evaluateDeep = evaluate . force diff --git a/source/library/Brittany/Internal/Transformations/Alt.hs b/source/library/Brittany/Internal/Transformations/Alt.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Transformations/Alt.hs @@ -0,0 +1,961 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Brittany.Internal.Transformations.Alt where + +import qualified Control.Monad.Memo as Memo +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import Data.HList.ContainsType +import qualified Data.List.Extra +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import qualified GHC.OldList as List +import Brittany.Internal.Config.Types +import Brittany.Internal.Prelude +import Brittany.Internal.PreludeUtils +import Brittany.Internal.Types +import Brittany.Internal.Utils + + + +data AltCurPos = AltCurPos + { _acp_line :: Int -- chars in the current line + , _acp_indent :: Int -- current indentation level + , _acp_indentPrep :: Int -- indentChange affecting the next Par + , _acp_forceMLFlag :: AltLineModeState + } + deriving Show + +data AltLineModeState + = AltLineModeStateNone + | AltLineModeStateForceML Bool -- true ~ decays on next wrap + | AltLineModeStateForceSL + | AltLineModeStateContradiction + -- i.e. ForceX False -> ForceX True -> None + deriving (Show) + +altLineModeRefresh :: AltLineModeState -> AltLineModeState +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = + AltLineModeStateContradiction + +altLineModeDecay :: AltLineModeState -> AltLineModeState +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction + +mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos +mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of + (AltLineModeStateContradiction, _) -> acp + (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } + (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp + (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> + acp { _acp_forceMLFlag = s } + _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } + + +-- removes any BDAlt's from the BriDoc +transformAlts + :: forall r w s + . ( Data.HList.ContainsType.ContainsType Config r + , Data.HList.ContainsType.ContainsType (Seq String) w + ) + => BriDocNumbered + -> MultiRWSS.MultiRWS r w s BriDoc +transformAlts = + MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) + . Memo.startEvalMemoT + . fmap unwrapBriDocNumbered + . rec + where + -- this function is exponential by nature and cannot be improved in any + -- way i can think of, and i've tried. (stupid StableNames.) + -- transWrap :: BriDoc -> BriDocNumbered + -- transWrap brDc = flip StateS.evalState (1::Int) + -- $ Memo.startEvalMemoT + -- $ go brDc + -- where + -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i + -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered + -- go = Memo.memo $ \bdX -> do + -- i <- lift $ incGet + -- fmap (\bd' -> (i,bd')) $ case bdX of + -- BDEmpty -> return $ BDFEmpty + -- BDLit t -> return $ BDFLit t + -- BDSeq list -> BDFSeq <$> go `mapM` list + -- BDCols sig list -> BDFCols sig <$> go `mapM` list + -- BDSeparator -> return $ BDFSeparator + -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd + -- BDSetBaseY bd -> BDFSetBaseY <$> go bd + -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd + -- BDPar ind line indented -> [ BDFPar ind line' indented' + -- | line' <- go line + -- , indented' <- go indented + -- ] + -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen + -- BDForceMultiline bd -> BDFForceMultiline <$> go bd + -- BDForceSingleline bd -> BDFForceSingleline <$> go bd + -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd + -- BDExternal k ks c t -> return $ BDFExternal k ks c t + -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd + -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd + -- BDLines lines -> BDFLines <$> go `mapM` lines + -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd + -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd + + + + rec + :: BriDocNumbered + -> Memo.MemoT + Int + [VerticalSpacing] + (MultiRWSS.MultiRWS r w (AltCurPos ': s)) + BriDocNumbered + rec bdX@(brDcId, brDc) = do + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let + indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd + mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } + sameLine' <- rec sameLine + mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let + lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (hasSpace1 lconf acp vs && lineCheck vs, bd) + ) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust + (\(_i :: Int, (b, x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ] + ) + $ zip [1 ..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let + lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) + ) + let + checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp + { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp + } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet + $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l : lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } + rec x + return $ reWrap $ BDFLines (l' : lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> + reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing _ bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess + $ "transformAlts: BDFDEBUG " + ++ s + ++ " (node-id=" + ++ show brDcId + ++ "): acp=" + ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 + :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + + sameLine + <= confUnpack (_lconfig_cols lconf) + && indent + + indentPrep + + par + <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + +getSpacing + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => BriDocNumbered + -> m (LineModeValidity VerticalSpacing) +getSpacing !bridoc = rec bridoc + where + rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) + rec (brDcId, brDc) = do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + result <- case brDc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLit t -> return $ LineModeValid $ VerticalSpacing + (Text.length t) + VerticalSpacingParNone + False + BDFSeq list -> sumVs <$> rec `mapM` list + BDFCols _sig list -> sumVs <$> rec `mapM` list + BDFSeparator -> + return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) + , _vs_paragraph = VerticalSpacingParSome 0 + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVs <- rec sameLine + mIndSp <- rec indented + return + $ [ VerticalSpacing lsp pspResult parFlagResult + | VerticalSpacing lsp mPsp _ <- mVs + , indSp <- mIndSp + , lineMax <- getMaxVS $ mIndSp + , let + pspResult = case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp lineMax + , let + parFlagResult = + mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp + ] + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + BDFAlt (alt : _) -> rec alt + BDFForceMultiline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> LineModeInvalid + _ -> mVs + BDFForceSingleline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> mVs + _ -> LineModeInvalid + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of + [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False + BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of + [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_ : _) -> do + lSps <- rec `mapM` ls + let (mVs : _) = lSps -- separated into let to avoid MonadFail + return + $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp pf) -> + VerticalSpacing (lsp + addInd) psp pf + BDFNonBottomSpacing b bd -> do + mVs <- rec bd + return $ mVs <|> LineModeValid + (VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- rec bd + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess + $ "getSpacing: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): mVs=" + ++ show r + return r + return result + maxVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs = foldl' + (liftM2 + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y + ) + False + ) + ) + (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) + sumVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs sps = foldl' (liftM2 go) initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y + ) + x3 + singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone + singleline _ = False + isPar (LineModeValid x) = _vs_parFlag x + isPar _ = False + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int + getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + +data SpecialCompare = Unequal | Smaller | Bigger + +getSpacings + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => Int + -> BriDocNumbered + -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] +getSpacings limit bridoc = preFilterLimit <$> rec bridoc + where + -- when we do `take K . filter someCondition` on a list of spacings, we + -- need to first (also) limit the size of the input list, otherwise a + -- _large_ input with a similarly _large_ prefix not passing our filtering + -- process could lead to exponential runtime behaviour. + -- TODO: 3 is arbitrary. + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3 * limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let + hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let + specialCompare vs1 vs2 = + if ((_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let + allowHangingQuasiQuotes = + config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = + take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . specialNub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] + return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> + VerticalSpacing + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp + ) + (mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1] -> + VerticalSpacing (Text.length t1) VerticalSpacingParNone False + (t1 : _) -> + VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True + | allowHangingQuasiQuotes + ] + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_ : _) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- map filterAndLimit <$> rec `mapM` ls + let + worbled = fmap reverse $ sequence $ reverse $ lSpss + sumF lSps@(lSp1 : _) = + VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False + sumF [] = + error + $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. + mVs <- rec bd + return $ if null mVs + then + [ VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] + else mVs <&> \vs -> vs + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess + $ "getSpacings: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): vs=" + ++ show (take 9 r) + return r + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y + ) + False + ) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y + ) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + +fixIndentationForMultiple + :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int +fixIndentationForMultiple acp indent = do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let + indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + -- for IndentPolicyMultiple, we restrict the amount of added + -- indentation in such a manner that we end up on a multiple of the + -- base indentation. + indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + pure $ if indPolicy == IndentPolicyMultiple + then + let + indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 + else indAddRaw diff --git a/source/library/Brittany/Internal/Transformations/Columns.hs b/source/library/Brittany/Internal/Transformations/Columns.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Transformations/Columns.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module 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 + + + +transformSimplifyColumns :: BriDoc -> BriDoc +transformSimplifyColumns = Uniplate.rewrite $ \case + -- BDWrapAnnKey annKey bd -> + -- BDWrapAnnKey annKey $ transformSimplify bd + BDEmpty -> Nothing + BDLit{} -> Nothing + BDSeq list + | any + (\case + BDSeq{} -> True + BDEmpty{} -> True + _ -> False + ) + list + -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_ : _) : rest) + | all + (\case + BDSeparator -> True + _ -> False + ) + rest + -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)]) + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines l -> l + x -> [x] + -- prior floating in + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) + -- post floating in + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] + -- ensureIndent float-in + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- matching col special transformation + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 + , BDCols sig2 cols2 <- List.last lines + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 + , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> + Just $ BDAddBaseY ind (BDLines [col1, col2]) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) + | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind (BDLines lines1) col2@(BDCols sig2 _) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) + -- | sig1==sig2 -> + -- Just $ BDPar + -- ind1 + -- (BDLines [BDCols sig1 cols1, BDCols sig]) + BDCols sig1 cols + | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 + -> Just + $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] + BDCols sig1 cols + | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 + $ List.init cols + ++ [BDPar ind line (BDLines $ List.init lines)] + , BDCols sig2 cols2 + ] + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing + BDIndentLevelPushCur{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing + BDForceSingleline{} -> Nothing + BDForwardLineMode{} -> Nothing + BDExternal{} -> Nothing + BDPlain{} -> Nothing + BDLines{} -> Nothing + BDAnnotationPrior{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing + BDForceParSpacing{} -> Nothing + BDDebug{} -> Nothing + BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Brittany/Internal/Transformations/Floating.hs b/source/library/Brittany/Internal/Transformations/Floating.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Transformations/Floating.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module 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 + + + +-- note that this is not total, and cannot be with that exact signature. +mergeIndents :: BrIndent -> BrIndent -> BrIndent +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = + BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" + + +transformSimplifyFloating :: BriDoc -> BriDoc +transformSimplifyFloating = stepBO .> stepFull + -- note that semantically, stepFull is completely sufficient. + -- but the bottom-up switch-to-top-down-on-match transformation has much + -- better complexity. + -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence + -- the push/pop cases would need to be copied over + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + BDAddBaseY BrIndentNone x -> Just x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + BDAddBaseY BrIndentNone x -> Just $ x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Brittany/Internal/Transformations/Indent.hs b/source/library/Brittany/Internal/Transformations/Indent.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Transformations/Indent.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module 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 + + + +-- prepare layouting by translating BDPar's, replacing them with Indents and +-- floating those in. This gives a more clear picture of what exactly is +-- affected by what amount of indentation. +transformSimplifyIndent :: BriDoc -> BriDoc +transformSimplifyIndent = Uniplate.rewrite $ \case + BDPar ind (BDLines lines) indented -> + Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented] + BDPar ind (BDCols sig cols) indented -> + Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented]) + BDPar BrIndentNone _ _ -> Nothing + BDPar ind x indented -> + Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented) + -- BDPar ind x indented -> + -- Just $ BDLines + -- [ BDAddBaseY ind x + -- , BDEnsureIndent ind indented + -- ] + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines l -> l + x -> [x] + BDLines [l] -> Just l + BDAddBaseY i (BDAnnotationPrior k x) -> + Just $ BDAnnotationPrior k (BDAddBaseY i x) + BDAddBaseY i (BDAnnotationKW k kw x) -> + Just $ BDAnnotationKW k kw (BDAddBaseY i x) + BDAddBaseY i (BDAnnotationRest k x) -> + Just $ BDAnnotationRest k (BDAddBaseY i x) + BDAddBaseY i (BDSeq l) -> + Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] + BDAddBaseY i (BDCols sig l) -> + Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] + BDAddBaseY _ lit@BDLit{} -> Just lit + + _ -> Nothing diff --git a/source/library/Brittany/Internal/Transformations/Par.hs b/source/library/Brittany/Internal/Transformations/Par.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Transformations/Par.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Internal.Transformations.Par where + +import Brittany.Internal.Prelude +import Brittany.Internal.Types +import Brittany.Internal.Utils + + + +transformSimplifyPar :: BriDoc -> BriDoc +transformSimplifyPar = transformUp $ \case + -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2] + -- BDPar line indented -> + -- Just $ BDLines [line, indented] + -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 -> + -- Just $ BDPar ind1 line (BDLines [p1, p2]) + x@(BDPar _ (BDPar _ BDPar{} _) _) -> x + BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> + BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) + BDPar ind1 (BDPar ind2 line p1) p2 -> + BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs + where + go = (=<<) $ \case + BDLines l -> go l + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x + -- BDCols sig cols | BDPar ind line indented <- List.last cols -> + -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented + -- BDPar BrIndentNone line indented -> + -- Just $ BDLines [line, indented] + BDEnsureIndent BrIndentNone x -> x + x -> x diff --git a/source/library/Brittany/Internal/Types.hs b/source/library/Brittany/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Types.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Brittany.Internal.Types where + +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Data.Data +import Data.Generics.Uniplate.Direct as Uniplate +import qualified Data.Kind as Kind +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text.Lazy.Builder as Text.Builder +import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) +import 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 +import Language.Haskell.GHC.ExactPrint.Types (Anns) +import qualified Safe + + +data PerItemConfig = PerItemConfig + { _icd_perBinding :: Map String (CConfig Maybe) + , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) + } + deriving Data.Data.Data + +type PPM = MultiRWSS.MultiRWS + '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] + +type PPMLocal = MultiRWSS.MultiRWS + '[Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] + +newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) + +data LayoutState = LayoutState + { _lstate_baseYs :: [Int] + -- ^ stack of number of current indentation columns + -- (not number of indentations). + , _lstate_curYOrAddNewline :: Either Int Int + -- ^ Either: + -- 1) number of chars in the current line. + -- 2) number of newlines to be inserted before inserting any + -- non-space elements. + , _lstate_indLevels :: [Int] + -- ^ stack of current indentation levels. set for + -- any layout-affected elements such as + -- let/do/case/where elements. + -- The main purpose of this member is to + -- properly align comments, as their + -- annotation positions are relative to the + -- current layout indentation level. + , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for + -- properly treating cases where comments + -- on the first indented element have an + -- annotation offset relative to the last + -- non-indented element, which is confusing. + , _lstate_comments :: Anns + , _lstate_commentCol :: Maybe Int -- this communicates two things: + -- firstly, that cursor is currently + -- at the end of a comment (so needs + -- newline before any actual content). + -- secondly, the column at which + -- insertion of comments started. + , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone + -- writes (any non-spaces) in the + -- current line. + -- , _lstate_isNewline :: NewLineState + -- -- captures if the layouter currently is in a new line, i.e. if the + -- -- current line only contains (indentation) spaces. + -- this is mostly superseeded by curYOrAddNewline, iirc. + , _lstate_commentNewlines :: Int -- number of newlines inserted due to + -- move-to-DP at a start of a comment. + -- Necessary because some keyword DPs + -- are relative to the last non-comment + -- entity (for some reason). + -- This is not very strictly reset to 0, + -- so we might in some cases get "artifacts" + -- from previous document elements. + -- But the worst effect at the moment would + -- be that we introduce less newlines on + -- moveToKWDP, which seems harmless enough. + } + +lstate_baseY :: LayoutState -> Int +lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs + +lstate_indLevel :: LayoutState -> Int +lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels + +-- evil, incomplete Show instance; only for debugging. +instance Show LayoutState where + show state = + "LayoutState" + ++ "{baseYs=" ++ show (_lstate_baseYs state) + ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) + ++ ",indLevels=" ++ show (_lstate_indLevels state) + ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) + ++ ",commentCol=" ++ show (_lstate_commentCol state) + ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) + ++ "}" + +-- data NewLineState = NewLineStateInit -- initial state. we do not know if in a +-- -- newline, really. by special-casing +-- -- this we can appropriately handle it +-- -- differently at use-site. +-- | NewLineStateYes +-- | NewLineStateNo +-- deriving Eq + +-- data LayoutSettings = LayoutSettings +-- { _lsettings_cols :: Int -- the thing that has default 80. +-- , _lsettings_indentPolicy :: IndentPolicy +-- , _lsettings_indentAmount :: Int +-- , _lsettings_indentWhereSpecial :: Bool -- indent where only 1 sometimes (TODO). +-- , _lsettings_indentListSpecial :: Bool -- use some special indentation for "," +-- -- when creating zero-indentation +-- -- multi-line list literals. +-- , _lsettings_importColumn :: Int +-- , _lsettings_initialAnns :: ExactPrint.Anns +-- } + +data BrittanyError + = ErrorInput String + -- ^ parsing failed + | ErrorUnusedComment String + -- ^ internal error: some comment went missing + | ErrorMacroConfig String String + -- ^ in-source config string parsing error; first argument is the parser + -- output and second the corresponding, ill-formed input. + | LayoutWarning String + -- ^ some warning + | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) + -- ^ internal error: pretty-printing is not implemented for type of node + -- in the syntax-tree + | ErrorOutputCheck + -- ^ checking the output for syntactic validity failed + +data BriSpacing = BriSpacing + { _bs_spacePastLineIndent :: Int -- space in the current, + -- potentially somewhat filled + -- line. + , _bs_spacePastIndent :: Int -- space required in properly + -- indented blocks below the + -- current line. + } + +data ColSig + = ColTyOpPrefix + -- any prefixed operator/paren/"::"/.. + -- expected to have exactly two colums. + -- e.g. ":: foo" + -- 111222 + -- "-> bar asd asd" + -- 11122222222222 + | ColPatternsFuncPrefix + -- pattern-part of the lhs, e.g. "func (foo a b) c _". + -- Has variable number of columns depending on the number of patterns. + | ColPatternsFuncInfix + -- pattern-part of the lhs, e.g. "Foo a <> Foo b". + -- Has variable number of columns depending on the number of patterns. + | ColPatterns + | ColCasePattern + | ColBindingLine (Maybe Text) + -- e.g. "func pat pat = expr" + -- 1111111111111222222 + -- or "pat | stmt -> expr" + -- 111111111112222222 + -- expected to have exactly two columns. + | ColGuard + -- e.g. "func pat pat | cond = ..." + -- 11111111111112222222 + -- or "pat | cond1, cond2 -> ..." + -- 1111222222222222222 + -- expected to have exactly two columns + | ColGuardedBody + -- e.g. | foofoo = 1 + -- | bar = 2 + -- 111111111222 + -- expected to have exactly two columns + | ColBindStmt + | ColDoLet -- the non-indented variant + | ColRec + | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRecDecl + | ColListComp + | ColList + | ColApp Text + | ColTuple + | ColTuples + | ColOpPrefix -- merge with ColList ? other stuff? + | ColImport + + -- TODO + deriving (Eq, Ord, Data.Data.Data, Show) + +data BrIndent = BrIndentNone + | BrIndentRegular + | BrIndentSpecial Int + deriving (Eq, Ord, Data.Data.Data, Show) + +type ToBriDocM = MultiRWSS.MultiRWS + '[Config, Anns] -- reader + '[[BrittanyError], Seq String] -- writer + '[NodeAllocIndex] -- state + +type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = Located sym -> ToBriDocM c + +data DocMultiLine + = MultiLineNo + | MultiLinePossible + deriving (Eq) + +-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot +-- of transformations on `BriDocF Identity`s and it is really annoying to +-- `Identity`/`runIdentity` everywhere. +data BriDoc + = -- BDWrapAnnKey AnnKey BriDoc + BDEmpty + | BDLit !Text + | BDSeq [BriDoc] -- elements other than the last should + -- not contains BDPars. + | BDCols ColSig [BriDoc] -- elements other than the last + -- should not contains BDPars + | BDSeparator -- semantically, space-unless-at-end-of-line. + | BDAddBaseY BrIndent BriDoc + | BDBaseYPushCur BriDoc + | BDBaseYPop BriDoc + | BDIndentLevelPushCur BriDoc + | BDIndentLevelPop BriDoc + | BDPar + { _bdpar_indent :: BrIndent + , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars + , _bdpar_indented :: BriDoc + } + -- | BDAddIndent BrIndent (BriDocF f) + -- | BDNewline + | BDAlt [BriDoc] + | BDForwardLineMode BriDoc + | BDExternal AnnKey + (Set AnnKey) -- set of annkeys contained within the node + -- to be printed via exactprint + Bool -- should print extra comment ? + Text + | BDPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) + | BDAnnotationPrior AnnKey BriDoc + | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc + | BDAnnotationRest AnnKey BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset + | BDLines [BriDoc] + | BDEnsureIndent BrIndent BriDoc + -- the following constructors are only relevant for the alt transformation + -- and are removed afterwards. They should never occur in any BriDoc + -- after the alt transformation. + | BDForceMultiline BriDoc + | BDForceSingleline BriDoc + | BDNonBottomSpacing Bool BriDoc + | BDSetParSpacing BriDoc + | BDForceParSpacing BriDoc + -- pseudo-deprecated + | BDDebug String BriDoc + deriving (Data.Data.Data, Eq, Ord) + +data BriDocF f + = -- BDWrapAnnKey AnnKey BriDoc + BDFEmpty + | BDFLit !Text + | BDFSeq [f (BriDocF f)] -- elements other than the last should + -- not contains BDPars. + | BDFCols ColSig [f (BriDocF f)] -- elements other than the last + -- should not contains BDPars + | BDFSeparator -- semantically, space-unless-at-end-of-line. + | BDFAddBaseY BrIndent (f (BriDocF f)) + | BDFBaseYPushCur (f (BriDocF f)) + | BDFBaseYPop (f (BriDocF f)) + | BDFIndentLevelPushCur (f (BriDocF f)) + | BDFIndentLevelPop (f (BriDocF f)) + | BDFPar + { _bdfpar_indent :: BrIndent + , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars + , _bdfpar_indented :: f (BriDocF f) + } + -- | BDAddIndent BrIndent (BriDocF f) + -- | BDNewline + | BDFAlt [f (BriDocF f)] + | BDFForwardLineMode (f (BriDocF f)) + | BDFExternal AnnKey + (Set AnnKey) -- set of annkeys contained within the node + -- to be printed via exactprint + Bool -- should print extra comment ? + Text + | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) + | BDFAnnotationPrior AnnKey (f (BriDocF f)) + | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) + | BDFAnnotationRest AnnKey (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset + | BDFLines [(f (BriDocF f))] + | BDFEnsureIndent BrIndent (f (BriDocF f)) + | BDFForceMultiline (f (BriDocF f)) + | BDFForceSingleline (f (BriDocF f)) + | BDFNonBottomSpacing Bool (f (BriDocF f)) + | BDFSetParSpacing (f (BriDocF f)) + | BDFForceParSpacing (f (BriDocF f)) + | BDFDebug String (f (BriDocF f)) + +-- deriving instance Data.Data.Data (BriDocF Identity) +deriving instance Data.Data.Data (BriDocF ((,) Int)) + +type BriDocFInt = BriDocF ((,) Int) +type BriDocNumbered = (Int, BriDocFInt) + +instance Uniplate.Uniplate BriDoc where + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x + uniplate (BDAnnotationPrior annKey bd) = + plate BDAnnotationPrior |- annKey |* bd + uniplate (BDAnnotationKW annKey kw bd) = + plate BDAnnotationKW |- annKey |- kw |* bd + uniplate (BDAnnotationRest annKey bd) = + plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw b bd) = + plate BDMoveToKWDP |- annKey |- kw |- b |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd + +newtype NodeAllocIndex = NodeAllocIndex Int + +-- TODO: rename to "dropLabels" ? +unwrapBriDocNumbered :: BriDocNumbered -> BriDoc +unwrapBriDocNumbered tpl = case snd tpl of + BDFEmpty -> BDEmpty + BDFLit t -> BDLit t + BDFSeq list -> BDSeq $ rec <$> list + BDFCols sig list -> BDCols sig $ rec <$> list + BDFSeparator -> BDSeparator + BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDFBaseYPop bd -> BDBaseYPop $ rec bd + BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDFPar ind line indented -> BDPar ind (rec line) (rec indented) + BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDFForwardLineMode bd -> BDForwardLineMode $ rec bd + BDFExternal k ks c t -> BDExternal k ks c t + BDFPlain t -> BDPlain t + BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd + BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd + BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd + BDFLines lines -> BDLines $ rec <$> lines + BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd + where rec = unwrapBriDocNumbered + +isNotEmpty :: BriDoc -> Bool +isNotEmpty BDEmpty = False +isNotEmpty _ = True + +-- this might not work. is not used anywhere either. +briDocSeqSpine :: BriDoc -> () +briDocSeqSpine = \case + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd + BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented + BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDPlain{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd + +briDocForceSpine :: BriDoc -> BriDoc +briDocForceSpine bd = briDocSeqSpine bd `seq` bd + + +data VerticalSpacingPar + = VerticalSpacingParNone -- no indented lines + | VerticalSpacingParSome Int -- indented lines, requiring this much + -- vertical space at most + | VerticalSpacingParAlways Int -- indented lines, requiring this much + -- vertical space at most, but should + -- be considered as having space for + -- any spacing validity check. + -- TODO: it might be wrong not to extend "always" to the none case, i.e. + -- we might get better properties of spacing operators by having a + -- product like (Normal|Always, None|Some Int). + deriving (Eq, Show) + +data VerticalSpacing + = VerticalSpacing + { _vs_sameLine :: !Int + , _vs_paragraph :: !VerticalSpacingPar + , _vs_parFlag :: !Bool + } + deriving (Eq, Show) + +newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) + deriving (Functor, Applicative, Monad, Show, Alternative) + +pattern LineModeValid :: forall t. t -> LineModeValidity t +pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t +pattern LineModeInvalid :: forall t. LineModeValidity t +pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t diff --git a/source/library/Brittany/Internal/Utils.hs b/source/library/Brittany/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Internal/Utils.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module 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 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 + + + +parDoc :: String -> PP.Doc +parDoc = PP.fsep . fmap PP.text . List.words + +parDocW :: [String] -> PP.Doc +parDocW = PP.fsep . fmap PP.text . List.words . List.unwords + + +showSDoc_ :: GHC.SDoc -> String +showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags + +showOutputable :: (GHC.Outputable a) => a -> String +showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags + +fromMaybeIdentity :: Identity a -> Maybe a -> Identity a +fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y + +fromOptionIdentity :: Identity a -> Maybe a -> Identity a +fromOptionIdentity x y = + Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y + +-- maximum monoid over N+0 +-- or more than N, because Num is allowed. +newtype Max a = Max { getMax :: a } + deriving (Eq, Ord, Show, Bounded, Num) + +instance (Num a, Ord a) => Semigroup (Max a) where + (<>) = Data.Coerce.coerce (max :: a -> a -> a) + +instance (Num a, Ord a) => Monoid (Max a) where + mempty = Max 0 + mappend = (<>) + +newtype ShowIsId = ShowIsId String deriving Data + +instance Show ShowIsId where + show (ShowIsId x) = x + +data A x = A ShowIsId x + deriving Data + +customLayouterF :: ExactPrint.Types.Anns -> LayouterF +customLayouterF anns layoutF = + DataToLayouter + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan + `ext2Q` located + where + DataToLayouter f = defaultLayouterF layoutF + simpleLayouter :: String -> NodeLayouter + simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) + showIsId :: ShowIsId -> NodeLayouter + showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s + fastString = + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + -> NodeLayouter + bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + srcSpan :: GHC.SrcSpan -> NodeLayouter + srcSpan ss = + simpleLayouter + -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" + $ "{" + ++ showOutputable ss + ++ "}" + located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter + located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a + where + annStr = case cast ss of + Just (s :: GHC.SrcSpan) -> + ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) + Nothing -> ShowIsId "nnnnnnnn" + +customLayouterNoAnnsF :: LayouterF +customLayouterNoAnnsF layoutF = + DataToLayouter + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan + `ext2Q` located + where + DataToLayouter f = defaultLayouterF layoutF + simpleLayouter :: String -> NodeLayouter + simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) + showIsId :: ShowIsId -> NodeLayouter + showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s + fastString = + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + -> NodeLayouter + bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + srcSpan :: GHC.SrcSpan -> NodeLayouter + srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" + located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter + located (GHC.L _ss a) = runDataToLayouter layoutF a + +-- displayBriDocTree :: BriDoc -> PP.Doc +-- displayBriDocTree = \case +-- BDWrapAnnKey annKey doc -> def "BDWrapAnnKey" +-- $ PP.text (show annKey) +-- $+$ displayBriDocTree doc +-- BDEmpty -> PP.text "BDEmpty" +-- BDLit t -> def "BDLit" $ PP.text (show t) +-- BDSeq list -> def "BDSeq" $ displayList list +-- BDCols sig list -> def "BDCols" $ PP.text (show sig) +-- $+$ displayList list +-- BDSeparator -> PP.text "BDSeparator" +-- BDPar rol indent lines -> def "BDPar" $ displayBriDocTree rol +-- $+$ PP.text (show indent) +-- $+$ displayList lines +-- BDAlt alts -> def "BDAlt" $ displayList alts +-- BDExternal ast _t -> def "BDExternal" (astToDoc ast) +-- BDSpecialPostCommentLoc _ -> PP.text "BDSpecialPostCommentLoc" +-- where +-- def x r = PP.text x $+$ PP.nest 2 r +-- displayList :: [BriDoc] -> PP.Doc +-- displayList [] = PP.text "[]" +-- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocTree x +-- : [PP.text "," <+> displayBriDocTree t | t<-xr] +-- ++ [PP.text "]"] + +-- displayBriDocSimpleTree :: BriDocSimple -> PP.Doc +-- displayBriDocSimpleTree = \case +-- BDSWrapAnnKey annKey doc -> def "BDSWrapAnnKey" +-- $ PP.text (show annKey) +-- $+$ displayBriDocSimpleTree doc +-- BDSLit t -> def "BDSLit" $ PP.text (show t) +-- BDSSeq list -> def "BDSSeq" $ displayList list +-- BDSCols sig list -> def "BDSCols" $ PP.text (show sig) +-- $+$ displayList list +-- BDSSeparator -> PP.text "BDSSeparator" +-- BDSPar rol indent lines -> def "BDSPar" $ displayBriDocSimpleTree rol +-- $+$ PP.text (show indent) +-- $+$ displayList lines +-- BDSExternal annKey _subKeys _t -> def "BDSExternal" (PP.text $ show annKey) +-- BDSSpecialPostCommentLoc _ -> PP.text "BDSSpecialPostCommentLoc" +-- where +-- def x r = PP.text x $+$ PP.nest 2 r +-- displayList :: [BriDocSimple] -> PP.Doc +-- displayList [] = PP.text "[]" +-- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocSimpleTree x +-- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr] +-- ++ [PP.text "]"] + +traceIfDumpConf + :: (MonadMultiReader Config m, Show a) + => String + -> (DebugConfig -> Identity (Semigroup.Last Bool)) + -> a + -> m () +traceIfDumpConf s accessor val = do + whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do + trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () + +tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () +tellDebugMess s = mTell $ Seq.singleton s + +tellDebugMessShow + :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () +tellDebugMessShow = tellDebugMess . show + +-- i should really put that into multistate.. +mModify :: MonadMultiState s m => (s -> s) -> m () +mModify f = mGet >>= mSet . f + +astToDoc :: Data ast => ast -> PP.Doc +astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast + +briDocToDoc :: BriDoc -> PP.Doc +briDocToDoc = astToDoc . removeAnnotations + where + removeAnnotations = Uniplate.transform $ \case + BDAnnotationPrior _ x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x + +briDocToDocWithAnns :: BriDoc -> PP.Doc +briDocToDocWithAnns = astToDoc + +annsDoc :: ExactPrint.Types.Anns -> PP.Doc +annsDoc = + printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) + +breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) +breakEither _ [] = ([], []) +breakEither fn (a1 : aR) = case fn a1 of + Left b -> (b : bs, cs) + Right c -> (bs, c : cs) + where (bs, cs) = breakEither fn aR + +spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) + where (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) + +data FirstLastView a + = FirstLastEmpty + | FirstLastSingleton a + | FirstLast a [a] a + +splitFirstLast :: [a] -> FirstLastView a +splitFirstLast [] = FirstLastEmpty +splitFirstLast [x] = FirstLastSingleton x +splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) + +-- TODO: move to uniplate upstream? +-- aka `transform` +transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +transformUp f = g where g = f . Uniplate.descend g +_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +_transformDown f = g where g = Uniplate.descend g . f +transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x +_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x + +-- | similar to List.lines, but treating the case of final newline character +-- in such a manner that this function is the inverse of @intercalate "\n"@. +lines' :: String -> [String] +lines' s = case break (== '\n') s of + (s1, []) -> [s1] + (s1, [_]) -> [s1, ""] + (s1, (_ : r)) -> s1 : lines' r + +absurdExt :: HsExtension.NoExtCon -> a +absurdExt = HsExtension.noExtCon diff --git a/source/library/Brittany/Main.hs b/source/library/Brittany/Main.hs new file mode 100644 --- /dev/null +++ b/source/library/Brittany/Main.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Brittany.Main where + +import Control.Monad (zipWithM) +import qualified Control.Monad.Trans.Except as ExceptT +import Data.CZipWith +import qualified Data.Either +import qualified Data.List.Extra +import qualified Data.Monoid +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import DataTreePrint +import GHC (GenLocated(L)) +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC +import qualified GHC.OldList as List +import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) +import 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 +import qualified System.Environment as Environment +import qualified System.Exit +import qualified System.FilePath.Posix as FilePath +import qualified System.IO +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.PrettyPrint as PP +import Text.Read (Read(..)) +import UI.Butcher.Monadic + + + +data WriteMode = Display | Inplace + +instance Read WriteMode where + readPrec = val "display" Display <|> val "inplace" Inplace + where val iden v = ReadPrec.lift $ ReadP.string iden >> return v + +instance Show WriteMode where + show Display = "display" + show Inplace = "inplace" + + +main :: IO () +main = do + progName <- Environment.getProgName + args <- Environment.getArgs + mainWith progName args + +mainWith :: String -> [String] -> IO () +mainWith progName args = + Environment.withProgName progName + . Environment.withArgs args + $ mainFromCmdParserWithHelpDesc mainCmdParser + +helpDoc :: PP.Doc +helpDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDocW + [ "Reformats one or more haskell modules." + , "Currently affects only the module head (imports/exports), type" + , "signatures and function bindings;" + , "everything else is left unmodified." + , "Based on ghc-exactprint, thus (theoretically) supporting all" + , "that ghc does." + ] + , parDoc $ "Example invocations:" + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany" + , PP.nest 2 $ PP.text "read from stdin, output to stdout" + ] + , PP.hang (PP.text "") 2 $ PP.vcat + [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" + , PP.nest 2 $ PP.vcat + [ PP.text "run on all modules in current directory (no backup!)" + , PP.text "4 spaces indentation" + ] + ] + , parDocW + [ "This program is written carefully and contains safeguards to ensure" + , "the output is syntactically valid and that no comments are removed." + , "Nonetheless, this is a young project, and there will always be bugs," + , "and ensuring that the transformation never changes semantics of the" + , "transformed source is currently not possible." + , "Please do check the output and do not let brittany override your large" + , "codebase without having backups." + ] + , parDoc $ "There is NO WARRANTY, to the extent permitted by law." + , parDocW + [ "This program is free software released under the AGPLv3." + , "For details use the --license flag." + ] + , parDoc $ "See https://github.com/lspitzner/brittany" + , parDoc + $ "Please report bugs at" + ++ " https://github.com/lspitzner/brittany/issues" + ] + +licenseDoc :: PP.Doc +licenseDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" + , parDoc $ "Copyright (C) 2019 PRODA LTD" + , parDocW + [ "This program is free software: you can redistribute it and/or modify" + , "it under the terms of the GNU Affero General Public License," + , "version 3, as published by the Free Software Foundation." + ] + , parDocW + [ "This program is distributed in the hope that it will be useful," + , "but WITHOUT ANY WARRANTY; without even the implied warranty of" + , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , "GNU Affero General Public License for more details." + ] + , parDocW + [ "You should have received a copy of the GNU Affero General Public" + , "License along with this program. If not, see" + , "." + ] + ] + + +mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () +mainCmdParser helpDesc = do + addCmdSynopsis "haskell source pretty printer" + addCmdHelp $ helpDoc + -- addCmd "debugArgs" $ do + addHelpCommand helpDesc + addCmd "license" $ addCmdImpl $ print $ licenseDoc + -- addButcherDebugCommand + reorderStart + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] mempty + noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty + configPaths <- addFlagStringParams + "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser + suppressOutput <- addSimpleBoolFlag + "" + ["suppress-output"] + (flagHelp $ parDoc + "suppress the regular output, i.e. the transformed haskell source" + ) + _verbosity <- addSimpleCountFlag + "v" + ["verbose"] + (flagHelp $ parDoc "[currently without effect; TODO]") + checkMode <- addSimpleBoolFlag + "c" + ["check-mode"] + (flagHelp + (PP.vcat + [ PP.text "check for changes but do not write them out" + , PP.text "exits with code 0 if no changes necessary, 1 otherwise" + , PP.text "and print file path(s) of files that have changes to stdout" + ] + ) + ) + writeMode <- addFlagReadParam + "" + ["write-mode"] + "(display|inplace)" + (flagHelp + (PP.vcat + [ PP.text "display: output for any input(s) goes to stdout" + , PP.text "inplace: override respective input file (without backup!)" + ] + ) + Data.Monoid.<> flagDefault Display + ) + inputParams <- addParamNoFlagStrings + "PATH" + (paramHelpStr "paths to input/inout haskell source files") + reorderStop + addCmdImpl $ void $ do + when printLicense $ do + print licenseDoc + System.Exit.exitSuccess + when printVersion $ do + do + putStrLn $ "brittany version " ++ showVersion version + putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" + putStrLn $ "Copyright (C) 2019 PRODA LTD" + putStrLn $ "There is NO WARRANTY, to the extent permitted by law." + System.Exit.exitSuccess + when printHelp $ do + liftIO + $ putStrLn + $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } + $ ppHelpShallow helpDesc + System.Exit.exitSuccess + + let + inputPaths = if null inputParams then [Nothing] else map Just inputParams + let + outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths + + configsToLoad <- liftIO $ if null configPaths + then + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- + runMaybeT + (if noUserConfig + then readConfigs cmdlineConfig configsToLoad + else readConfigsWithUserConfig cmdlineConfig configsToLoad + ) + >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + when (config & _conf_debug & _dconf_dump_config & confUnpack) + $ trace (showConfigYaml config) + $ return () + + results <- zipWithM + (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths + + if checkMode + then when (Changes `elem` (Data.Either.rights results)) + $ System.Exit.exitWith (System.Exit.ExitFailure 1) + else case results of + xs | all Data.Either.isRight xs -> pure () + [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + + +data ChangeStatus = Changes | NoChanges + deriving (Eq) + +-- | The main IO parts for the default mode of operation, and after commandline +-- and config stuff is processed. +coreIO + :: (String -> IO ()) -- ^ error output function. In parallel operation, you + -- may want serialize the different outputs and + -- consequently not directly print to stderr. + -> Config -- ^ global program config. + -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so + -- currently not part of program config. + -> Bool -- ^ whether we are (just) in check mode. + -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. + -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. + -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. +coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = + ExceptT.runExceptT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + -- there is a good of code duplication between the following code and the + -- `pureModuleTransform` function. Unfortunately, there are also a good + -- amount of slight differences: This module is a bit more verbose, and + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- the flag will do the following: insert a marker string + -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + -- The flag is intentionally misspelled to prevent clashing with + -- inline-config stuff. + let + hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let + exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + (parseResult, originalContents) <- case inputPathM of + Nothing -> do + -- TODO: refactor this hack to not be mixed into parsing logic + let + hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let + hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id + inputString <- liftIO System.IO.getContents + parseRes <- liftIO $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) + return (parseRes, Text.pack inputString) + Just p -> liftIO $ do + parseRes <- parseModule ghcOptions p cppCheckFunc + inputText <- Text.IO.readFile p + -- The above means we read the file twice, but the + -- GHC API does not really expose the source it + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> + -- handle still open -> write below crashes - evil.) + return (parseRes, inputText) + case parseResult of + Left left -> do + putErrorLn "parse error:" + putErrorLn left + ExceptT.throwE 60 + Right (anns, parsedSource, hasCPP) -> do + (inlineConf, perItemConf) <- + case + extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + of + Left (err, input) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + ExceptT.throwE 61 + Right c -> -- trace (showTree c) $ + pure c + let moduleConf = cZipWith fromOptionIdentity config inlineConf + when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + let + disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack + (errsWarns, outSText, hasChanges) <- do + if + | disableFormatting -> do + pure ([], originalContents, False) + | exactprintOnly -> do + let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + pure ([], r, r /= originalContents) + | otherwise -> do + let + omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return + $ pPrintModule moduleConf perItemConf anns parsedSource + else liftIO $ pPrintModuleAndCheck + moduleConf + perItemConf + anns + parsedSource + let + hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let + out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + else outRaw + out' <- if moduleConf & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out', out' /= originalContents) + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 + unless (null errsWarns) $ do + let + groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns + groupedErrsWarns `forM_` \case + (ErrorOutputCheck{} : _) -> do + putErrorLn + $ "ERROR: brittany pretty printer" + ++ " returned syntactically invalid result." + (ErrorInput str : _) -> do + putErrorLn $ "ERROR: parse error: " ++ str + uns@(ErrorUnknownNode{} : _) -> do + putErrorLn + $ "WARNING: encountered unknown syntactical constructs:" + uns `forM_` \case + ErrorUnknownNode str ast@(L loc _) -> do + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) + when + (config + & _conf_debug + & _dconf_dump_ast_unknown + & confUnpack + ) + $ do + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + putErrorLn + " -> falling back on exactprint for this element of the module" + warns@(LayoutWarning{} : _) -> do + putErrorLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putErrorLn str + _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComment{} : _) -> do + putErrorLn + $ "Error: detected unprocessed comments." + ++ " The transformation output will most likely" + ++ " not contain some of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> error "cannot happen (TM)" + (ErrorMacroConfig err input : _) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let + hasErrors = + if config & _conf_errorHandling & _econf_Werror & confUnpack + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) + outputOnErrs = + config + & _conf_errorHandling + & _econf_produceOutputOnErrors + & confUnpack + shouldOutput = + not suppressOutput + && not checkMode + && (not hasErrors || outputOnErrs) + + when shouldOutput + $ addTraceSep (_conf_debug config) + $ case outputPathM of + Nothing -> liftIO $ Text.IO.putStr $ outSText + Just p -> liftIO $ do + let + isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges + unless isIdentical $ Text.IO.writeFile p $ outSText + + when (checkMode && hasChanges) $ case inputPathM of + Nothing -> pure () + Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p + + when hasErrors $ ExceptT.throwE 70 + return (if hasChanges then Changes else NoChanges) + where + addTraceSep conf = + if or + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] + then trace "----" + else id diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany - ( parsePrintModule - , staticDefaultConfig - , forwardOptionsSyntaxExtsEnabled - , userConfigPath - , findLocalConfigPath - , readConfigs - , readConfigsWithUserConfig - , Config - , CConfig(..) - , CDebugConfig(..) - , CLayoutConfig(..) - , CErrorHandlingConfig(..) - , CForwardOptions(..) - , CPreProcessorConfig(..) - , BrittanyError(..) - ) where - -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ /dev/null @@ -1,660 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal - ( parsePrintModule - , parsePrintModuleTests - , pPrintModule - , pPrintModuleAndCheck - -- re-export from utils: - , parseModule - , parseModuleFromString - , extractCommentConfigs - , getTopLevelDeclNameMap - ) where - -import Control.Monad.Trans.Except -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Char (isSpace) -import Data.HList.HList -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Data.Yaml -import qualified GHC hiding (parseModule) -import GHC (GenLocated(L)) -import qualified GHC.Driver.Session as GHC -import GHC.Hs -import qualified GHC.LanguageExtensions.Type as GHC -import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.SrcLoc (SrcSpan) -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Indent -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified UI.Butcher.Monadic as Butcher - - - -data InlineConfigTarget - = InlineConfigTargetModule - | InlineConfigTargetNextDecl -- really only next in module - | InlineConfigTargetNextBinding -- by name - | InlineConfigTargetBinding String - -extractCommentConfigs - :: ExactPrint.Anns - -> TopLevelDeclNameMap - -> Either (String, String) (CConfig Maybe, PerItemConfig) -extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do - let - commentLiness = - [ ( k - , [ x - | (ExactPrint.Comment x _ _, _) <- - ( ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ) - ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] - ) - | (k, ann) <- Map.toList anns - ] - let configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - ( ("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) - let - configParser = Butcher.addAlternatives - [ ( "commandline-config" - , \s -> "-" `isPrefixOf` dropWhile (== ' ') s - , cmdlineConfigParser - ) - , ( "yaml-config-document" - , \s -> "{" `isPrefixOf` dropWhile (== ' ') s - , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") - $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) - . either (const Nothing) Just - . Data.Yaml.decodeEither' - . Data.ByteString.Char8.pack - -- TODO: use some proper utf8 encoder instead? - ) - ] - parser = do -- we will (mis?)use butcher here to parse the inline config - -- line. - let nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) - Butcher.addCmd "-next-declaration" nextDecl - Butcher.addCmd "-Next-Declaration" nextDecl - Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) - Butcher.addCmd "-next-binding" nextBinding - Butcher.addCmd "-Next-Binding" nextBinding - Butcher.addCmd "-NEXT-BINDING" nextBinding - let disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-binding" disableNextBinding - Butcher.addCmd "-Disable-Next-Binding" disableNextBinding - Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-declaration" disableNextDecl - Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl - Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) - Butcher.addCmd "-disable" disableFormatting - Butcher.addCmd "@" $ do - -- Butcher.addCmd "module" $ do - -- conf <- configParser - -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) - Butcher.addNullCmd $ do - bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetModule, conf) - lineConfigss <- configLiness `forM` \(k, ss) -> do - r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c - pure (k, r) - - let perModule = foldl' - (<>) - mempty - [ conf - | (_ , lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf ) <- lineConfigs - ] - let - perBinding = Map.fromListWith - (<>) - [ (n, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs - , n <- case target of - InlineConfigTargetBinding s -> [s] - InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> - [name] - _ -> [] - ] - let - perKey = Map.fromListWith - (<>) - [ (k, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs - , case target of - InlineConfigTargetNextDecl -> True - InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> - True - _ -> False - ] - - pure - $ ( perModule - , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } - ) - - -getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap -getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = - TopLevelDeclNameMap $ Map.fromList - [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls - , (name : _) <- [getDeclBindingNames decl] - ] - - --- | Exposes the transformation in an pseudo-pure fashion. The signature --- contains `IO` due to the GHC API not exposing a pure parsing function, but --- there should be no observable effects. --- --- Note that this function ignores/resets all config values regarding --- debugging, i.e. it will never use `trace`/write to stderr. --- --- Note that the ghc parsing function used internally currently is wrapped in --- `mask_`, so cannot be killed easily. If you don't control the input, you --- may wish to put some proper upper bound on the input's size as a timeout --- won't do. -parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) -parsePrintModule configWithDebugs inputText = runExceptT $ do - let config = - configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack - let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack - (anns, parsedSource, hasCPP) <- do - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - parseResult <- lift $ parseModuleFromString - ghcOptions - "stdin" - cppCheckFunc - (hackTransform $ Text.unpack inputText) - case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x - (inlineConf, perItemConf) <- - either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf - let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack - if disableFormatting - then do - return inputText - else do - (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource - else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s - pure $ if hackAroundIncludes - then - ( ews - , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn - (TextL.pack "\n") - outRaw - ) - else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) - if hasErrors - then throwE $ errsWarns - else pure $ TextL.toStrict outputTextL - - - --- BrittanyErrors can be non-fatal warnings, thus both are returned instead --- of an Either. --- This should be cleaned up once it is clear what kinds of errors really --- can occur. -pPrintModule - :: Config - -> PerItemConfig - -> ExactPrint.Anns - -> GHC.ParsedSource - -> ([BrittanyError], TextL.Text) -pPrintModule conf inlineConf anns parsedModule = - let ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) - -- unless () $ do - -- - -- debugStrings `forM_` \s -> - -- trace s $ return () - --- | Additionally checks that the output compiles again, appending an error --- if it does not. -pPrintModuleAndCheck - :: Config - -> PerItemConfig - -> ExactPrint.Anns - -> GHC.ParsedSource - -> IO ([BrittanyError], TextL.Text) -pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity - let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] - return (errs', output) - - --- used for testing mostly, currently. --- TODO: use parsePrintModule instead and remove this function. -parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) -parsePrintModuleTests conf filename input = do - let inputStr = Text.unpack input - parseResult <- parseModuleFromString - (conf & _conf_forward & _options_ghc & runIdentity) - filename - (const . pure $ Right ()) - inputStr - case parseResult of - Left err -> return $ Left err - Right (anns, parsedModule, _) -> runExceptT $ do - (inlineConf, perItemConf) <- - case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x - let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (errs, ltext) <- if omitCheck - then return $ pPrintModule moduleConf perItemConf anns parsedModule - else lift - $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule - if null errs - then pure $ TextL.toStrict $ ltext - else - let - errStrs = errs <&> \case - ErrorInput str -> str - ErrorUnusedComment str -> str - LayoutWarning str -> str - ErrorUnknownNode str _ -> str - ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs - --- this approach would for if there was a pure GHC.parseDynamicFilePragma. --- Unfortunately that does not exist yet, so we cannot provide a nominally --- pure interface. - --- parsePrintModuleTests :: Text -> Either String Text --- parsePrintModuleTests input = do --- let dflags = GHC.unsafeGlobalDynFlags --- let fakeFileName = "SomeTestFakeFileName.hs" --- let pragmaInfo = GHC.getOptions --- dflags --- (GHC.stringToStringBuffer $ Text.unpack input) --- fakeFileName --- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo --- let parseResult = ExactPrint.Parsers.parseWith --- dflags1 --- fakeFileName --- GHC.parseModule --- inputStr --- case parseResult of --- Left (_, s) -> Left $ "parsing error: " ++ s --- Right (anns, parsedModule) -> do --- let (out, errs) = runIdentity --- $ runMultiRWSTNil --- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW --- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW --- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns --- $ ppModule parsedModule --- if (not $ null errs) --- then do --- let errStrs = errs <&> \case --- ErrorUnusedComment str -> str --- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs --- else return $ TextL.toStrict $ Text.Builder.toLazyText out - -toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a -toLocal conf anns m = do - (x, write) <- - lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m - MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) - pure x - -ppModule :: GenLocated SrcSpan HsModule -> PPM () -ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do - defaultAnns <- do - anns <- mAsk - let annKey = ExactPrint.mkAnnKey lmod - let annMap = Map.findWithDefault Map.empty annKey anns - let isEof = (== ExactPrint.AnnEofPos) - let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } - pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap - - post <- ppPreamble lmod - decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl - let declBindingNames = getDeclBindingNames decl - inlineConf <- mAsk - let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk - <&> \annMap -> - Map.union defaultAnns $ - Map.findWithDefault Map.empty declAnnKey annMap - - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns - - config <- mAsk - - let config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) - - let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack - toLocal config' filteredAnns $ do - bd <- if exactprintOnly - then briDocMToPPM $ briDocByExactNoComment decl - else do - (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl - mTell debugs - mTell errs - if null errs - then pure r - else briDocMToPPM $ briDocByExactNoComment decl - layoutBriDoc bd - - let finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post - post `forM_` \case - (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do - ppmMoveToExactLoc l - mTell $ Text.Builder.fromString cmStr - (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm - | span <- ExactPrint.commentIdentifier cm - -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) - _ -> return () - -getDeclBindingNames :: LHsDecl GhcPs -> [String] -getDeclBindingNames (L _ decl) = case decl of - SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) - ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] - - --- Prints the information associated with the module annotation --- This includes the imports -ppPreamble - :: GenLocated SrcSpan HsModule - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L loc m@HsModule{}) = do - filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap - -- Since ghc-exactprint adds annotations following (implicit) - -- modules to both HsModule and the elements in the module - -- this can cause duplication of comments. So strip - -- attached annotations that come after the module's where - -- from the module node - config <- mAsk - let shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - - let - (filteredAnns', post) = - case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of - Nothing -> (filteredAnns, []) - Just mAnn -> - let - modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post') = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.annsDP = pre } - filteredAnns'' = - Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in - (filteredAnns'', post') - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns' - - if shouldReformatPreamble - then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc - else - let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule - return post - -_sigHead :: Sig GhcPs -> String -_sigHead = \case - TypeSig _ names _ -> - "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) - _ -> "unknown sig" - -_bindHead :: HsBind GhcPs -> String -_bindHead = \case - FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) - PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" - - - -layoutBriDoc :: BriDocNumbered -> PPMLocal () -layoutBriDoc briDoc = do - -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do - -- Note that briDoc is BriDocNumbered, but state type is BriDoc. - -- That's why the alt-transform looks a bit special here. - traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw - $ briDocToDoc - $ unwrapBriDocNumbered - $ briDoc - -- bridoc transformation: remove alts - transformAlts briDoc >>= mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyFloating .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating - -- bridoc transformation: par removal - mGet >>= transformSimplifyPar .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyColumns .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns - -- bridoc transformation: indent - mGet >>= transformSimplifyIndent .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - - anns :: ExactPrint.Anns <- mAsk - - let state = LayoutState { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - - let remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] - remainingComments - `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) - - return $ () diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ /dev/null @@ -1,707 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.Backend where - -import qualified Control.Monad.Trans.State.Strict as StateS -import qualified Data.Either as Either -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - - - -type ColIndex = Int - -data ColumnSpacing - = ColumnSpacingLeaf Int - | ColumnSpacingRef Int Int - -type ColumnBlock a = [a] -type ColumnBlocks a = Seq [a] -type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) - -- (ratio of hasSpace, maximum, raw) - -data ColInfo - = ColInfoStart -- start value to begin the mapAccumL. - | ColInfoNo BriDoc - | ColInfo ColIndex ColSig [(Int, ColInfo)] - -instance Show ColInfo where - show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list - -data ColBuildState = ColBuildState - { _cbs_map :: ColMap1 - , _cbs_index :: ColIndex - } - -type LayoutConstraints m = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) - -layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () -layoutBriDocM = \case - BDEmpty -> do - return () -- can it be that simple - BDLit t -> do - layoutIndentRestorePostComment - layoutRemoveIndentLevelLinger - layoutWriteAppend t - BDSeq list -> do - list `forM_` layoutBriDocM - -- in this situation, there is nothing to do about cols. - -- i think this one does not happen anymore with the current simplifications. - -- BDCols cSig list | BDPar sameLine lines <- List.last list -> - -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines - BDCols _ list -> do - list `forM_` layoutBriDocM - BDSeparator -> do - layoutAddSepSpace - BDAddBaseY indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ layoutBriDocM bd - BDBaseYPushCur bd -> do - layoutBaseYPushCur - layoutBriDocM bd - BDBaseYPop bd -> do - layoutBriDocM bd - layoutBaseYPop - BDIndentLevelPushCur bd -> do - layoutIndentLevelPushCur - layoutBriDocM bd - BDIndentLevelPop bd -> do - layoutBriDocM bd - layoutIndentLevelPop - BDEnsureIndent indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteEnsureBlock - layoutBriDocM bd - BDPar indent sameLine indented -> do - layoutBriDocM sameLine - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteNewlineBlock - layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt:_) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd - BDExternal annKey subKeys shouldAddComment t -> do - let tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines - anns :: ExactPrint.Anns <- mAsk - when shouldAddComment $ do - layoutWriteAppend - $ Text.pack - $ "{-" - ++ show (annKey, Map.lookup annKey anns) - ++ "-}" - zip [1 ..] tlines `forM_` \(i, l) -> do - layoutWriteAppend $ l - unless (i == tlineCount) layoutWriteNewlineBlock - do - state <- mGet - let filterF k _ = not $ k `Set.member` subKeys - mSet $ state - { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state - } - BDPlain t -> do - layoutWriteAppend t - BDAnnotationPrior annKey bd -> do - state <- mGet - let m = _lstate_comments state - let moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey - mAnn <- do - let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - annKey - m - } - return mAnn - case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction - Just priors -> do - -- layoutResetSepSpace - priors - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) - -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - moveToExactLocationAction - layoutBriDocM bd - BDAnnotationKW annKey keyword bd -> do - layoutBriDocM bd - mComments <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let mToSpan = case mAnn of - Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just - annR - _ -> Nothing - case mToSpan of - Just anns -> do - let (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annsDP = rest }) - annKey - m - } - return $ nonEmpty comments - _ -> return Nothing - case mComments of - Nothing -> pure () - Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDAnnotationRest annKey bd -> do - layoutBriDocM bd - annMay <- do - state <- mGet - let m = _lstate_comments state - pure $ Map.lookup annKey m - let mComments = nonEmpty . extractAllComments =<< annMay - let semiCount = length [ () - | Just ann <- [ annMay ] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- mAsk <&> - _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack - mModify $ \state -> state - { _lstate_comments = Map.adjust - ( \ann -> ann { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = - flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } - ) - annKey - (_lstate_comments state) - } - case mComments of - Nothing -> do - when shouldAddSemicolonNewlines $ do - [1..semiCount] `forM_` const layoutWriteNewline - Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do - mDP <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let relevant = [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] - -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] - case relevant of - [] -> pure Nothing - (ExactPrint.Types.DP (y, x):_) -> do - mSet state { _lstate_commentNewlines = 0 } - pure $ Just (y - _lstate_commentNewlines state, x) - case mDP of - Nothing -> pure () - Just (y, x) -> - -- we abuse this, as we probably will print the KW next, which is - -- _not_ a comment.. - layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 - layoutBriDocM bd - BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd - BDDebug s bd -> do - mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" - layoutBriDocM bd - -briDocLineLength :: BriDoc -> Int -briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc - -- the state encodes whether a separator was already - -- appended at the current position. - where - rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds - BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do - x <- StateS.get - return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - -briDocIsMultiLine :: BriDoc -> Bool -briDocIsMultiLine briDoc = rec briDoc - where - rec :: BriDoc -> Bool - rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_ ] -> False - BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - --- In theory --- ========= - --- .. this algorithm works roughly in these steps: --- --- 1. For each line, get the (nested) column info, descending as far as --- BDCols nodes go. The column info is a (rose) tree where the leafs --- are arbitrary (non-BDCols) BriDocs. --- 2. Walk through the lines and compare its column info with that of its --- predecessor. If both are non-leafs and the column "signatures" align --- (they don't align e.g. when they are totally different syntactical --- structures or the number of children differs), mark these parts of --- the two tree structures as connected and recurse to its children --- (i.e. again comparing the children in this line with the children in --- the previous line). --- 3. What we now have is one tree per line, and connections between "same" --- nodes between lines. These connection can span multiple lines. --- We next look at spacing information. This is available at the leafs, --- but in this step we aggregate _over connections_. At the top level, this --- gives us one piece of data: How long would each line be, if we fully --- aligned everything (kept all connections "active"). In contrast to --- just taking the sum of all leafs for each tree, this line length includes --- the spaces used for alignment. --- 4. Treat those lines where alignment would result in overflowing of the --- column limit. This "treatment" is currently configurable, and can e.g. --- mean: --- a) we stop alignment alltogether, --- b) we remove alignment just from the overflowing lines, --- c) we reduce the number of spaces inserted in overflowing lines using --- some technique to make them not overflow, but without reducing the --- space insertion to zero, --- d) don't do anything --- 5. Actually print the lines, walking over each tree and inserting spaces --- according to the info and decisions gathered in the previous steps. --- --- Possible improvements --- ===================== --- --- - If alignment is disabled for specific lines, the aggregated per-connection --- info of those lines is still retained and not recalculated. This can --- result in spaces being inserted to create alignment with a line that --- would overflow and thus gets disabled entirely. --- An better approach would be to repeat step 3 after marking overflowing --- lines as such, and not include the overflowing spacings as references --- for non-overflowing ones. In the simplest case one additional iteration --- would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine --- this and first remove alignment in the deepest parts of the tree for --- overflowing lines, repeating and moving upwards until no lines are --- anymore overflowing. --- Further, it may make sense to break up connections when overflowing would --- occur. --- - It may also make sense to not filter all overflowing lines, but remove --- them one-by-one and in each step recalculate the aggregated connection --- spacing info. Because removing one overflowing line from the calculation --- may very well cause another previously overflowing line to not overflow --- any longer. --- There is also a nasty optimization problem hiding in there (find the --- minimal amount of alignment disabling that results in no overflows) --- but that is overkill. --- --- (with both these improvements there would be quite some repetition between --- steps 3 and 4, but it should be possible to ensure termination. Still, --- performance might become an issue as such an approach is not necessarily --- linear in bridoc size any more.) --- --- In practice --- =========== --- --- .. the current implementation is somewhat sloppy. Steps 1 and 2 --- are executed in one step, step 3 already applies one strategy that disables --- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some --- of the calculations one might expect to occur in step 3. Steps 4 and 5 --- are executed in the same recursion, too. --- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue --- mentioned in the first "possible improvement". -alignColsLines :: LayoutConstraints m => [BriDoc] -> m () -alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do - -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) - curX <- do - state <- mGet - return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe - 0 - (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack - alignBreak <- - mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack - case () of - _ -> do - -- tellDebugMess ("processedMap: " ++ show processedMap) - sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos - <&> processInfo colMax processedMap - where - (colInfos, finalState) = - StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) - -- maxZipper :: [Int] -> [Int] -> [Int] - -- maxZipper [] ys = ys - -- maxZipper xs [] = xs - -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr - colAggregation :: [Int] -> Int - colAggregation [] = 0 -- this probably cannot happen the way we call - -- this function, because _cbs_map only ever - -- contains nonempty Seqs. - colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ] - where alignMax' = max 0 alignMax - - processedMap :: ColMap2 - processedMap = - fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> - let - colss = colSpacingss <&> \spss -> case reverse spss of - [] -> [] - (xN:xR) -> - reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR - where - fLast (ColumnSpacingLeaf len ) = len - fLast (ColumnSpacingRef len _) = len - fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of - Nothing -> 0 - Just (_, maxs, _) -> sum maxs - maxCols = {-Foldable.foldl1 maxZipper-} - fmap colAggregation $ transpose $ Foldable.toList colss - (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols - counter count l = if List.last posXs + List.last l <= colMax - then count + 1 - else count - ratio = fromIntegral (foldl counter (0 :: Int) colss) - / fromIntegral (length colss) - in - (ratio, maxCols, colss) - - mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocs bds = mergeBriDocsW ColInfoStart bds - - mergeBriDocsW - :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd:bdr) = do - info <- mergeInfoBriDoc True lastInfo bd - infor <- mergeBriDocsW - -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) - (if shouldBreakAfter bd then ColInfoStart else info) - bdr - return $ info : infor - - -- even with alignBreak config flag, we don't stop aligning for certain - -- ColSigs - the ones with "False" below. The main reason is that - -- there are uses of BDCols where they provide the alignment of several - -- consecutive full larger code segments, for example ColOpPrefix. - -- Motivating example is - -- > foo - -- > $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -- > , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - -- > ] - -- > ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ] - -- If we break the alignment here, then all three lines for the first - -- list move left by one, which is horrible. We really don't want to - -- break whole-block alignments. - -- For list, listcomp, tuple and tuples the reasoning is much simpler: - -- alignment should not have much effect anyways, so i simply make the - -- choice here that enabling alignment is the safer route for preventing - -- potential glitches, and it should never have a negative effect. - -- For RecUpdate the argument is much less clear - it is mostly a - -- personal preference to not break alignment for those, even if - -- multiline. Really, this should be configurable.. (TODO) - shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = alignBreak && - briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True - - mergeInfoBriDoc - :: Bool - -> ColInfo - -> BriDoc - -> StateS.StateT ColBuildState Identity ColInfo - mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = - \case - brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs - -> do - let - isLastList = if lastFlag - then (==length subDocs) <$> [1 ..] - else repeat False - infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs - `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs - let trueSpacings = getTrueSpacings (zip curLengths infos) - do -- update map - s <- StateS.get - let m = _cbs_map s - let (Just (_, spaces)) = IntMapS.lookup infoInd m - StateS.put s - { _cbs_map = IntMapS.insert - infoInd - (lastFlag, spaces Seq.|> trueSpacings) - m - } - return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise - -> briDocToColInfo lastFlag brdc - brdc -> return $ ColInfoNo brdc - -briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo -briDocToColInfo lastFlag = \case - BDCols sig list -> withAlloc lastFlag $ \ind -> do - let isLastList = - if lastFlag then (==length list) <$> [1 ..] else repeat False - subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos - let trueSpacings = getTrueSpacings lengthInfos - return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) - bd -> return $ ColInfoNo bd - -getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] -getTrueSpacings lengthInfos = lengthInfos <&> \case - (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _ ) -> ColumnSpacingLeaf len - -withAlloc - :: Bool - -> ( ColIndex - -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) - ) - -> StateS.State ColBuildState ColInfo -withAlloc lastFlag f = do - cbs <- StateS.get - let ind = _cbs_index cbs - StateS.put $ cbs { _cbs_index = ind + 1 } - (space, info) <- f ind - StateS.get >>= \c -> StateS.put - $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } - return info - -processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () -processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ - do - colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do - state <- mGet - -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) - let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state - return $ case _lstate_curYOrAddNewline state of - Left i -> case _lstate_commentCol state of - Nothing -> spaceAdd + i - Just c -> c - Right{} -> spaceAdd - let colMax = min colMaxConf (curX + maxSpace) - -- tellDebugMess $ show curX - let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l - let maxCols = zipWith max maxCols1 maxCols2 - let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols - -- handle the cases that the vertical alignment leads to more than max - -- cols: - -- this is not a full fix, and we must correct individually in addition. - -- because: the (at least) line with the largest element in the last - -- column will always still overflow, because we just updated the column - -- sizes in such a way that it works _if_ we have sizes (*factor) - -- in each column. but in that line, in the last column, we will be - -- forced to occupy the full vertical space, not reduced by any factor. - let fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (*factor) .> truncate - _ -> posXs - let spacings = zipWith (-) - (List.tail fixedPosXs ++ [min maxX colMax]) - fixedPosXs - -- tellDebugMess $ "ind = " ++ show ind - -- tellDebugMess $ "maxCols = " ++ show maxCols - -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs - -- tellDebugMess $ "list = " ++ show list - -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct - case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct - ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct - -processInfoIgnore :: LayoutConstraints m => ColInfo -> m () -processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ /dev/null @@ -1,522 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.BackendUtils where - -import qualified Data.Data -import qualified Data.Either -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (Located) -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint - - - -traceLocal - :: (MonadMultiState LayoutState m) - => a - -> m () -traceLocal _ = return () - - -layoutWriteAppend - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Text - -> m () -layoutWriteAppend t = do - traceLocal ("layoutWriteAppend", t) - state <- mGet - case _lstate_curYOrAddNewline state of - Right i -> do - replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" - Left{} -> do - return () - let spaces = fromMaybe 0 $ _lstate_addSepSpace state - mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') - mTell $ Text.Builder.fromText $ t - mModify $ \s -> s - { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces - , _lstate_addSepSpace = Nothing - } - -layoutWriteAppendSpaces - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Int - -> m () -layoutWriteAppendSpaces i = do - traceLocal ("layoutWriteAppendSpaces", i) - unless (i == 0) $ do - state <- mGet - mSet $ state - { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state - } - -layoutWriteAppendMultiline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => [Text] - -> m () -layoutWriteAppendMultiline ts = do - traceLocal ("layoutWriteAppendMultiline", ts) - case ts of - [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. - (l:lr) -> do - layoutWriteAppend l - lr `forM_` \x -> do - layoutWriteNewline - layoutWriteAppend x - --- adds a newline and adds spaces to reach the base column. -layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => m () -layoutWriteNewlineBlock = do - traceLocal ("layoutWriteNewlineBlock") - state <- mGet - mSet $ state { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - } - --- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m --- , MonadMultiWriter (Seq String) m) => Int -> m () --- layoutMoveToIndentCol i = do --- #if INSERTTRACES --- tellDebugMessShow ("layoutMoveToIndentCol", i) --- #endif --- state <- mGet --- mSet $ state --- { _lstate_addSepSpace = Just --- $ if isJust $ _lstate_addNewline state --- then i --- else _lstate_indLevelLinger state + i - _lstate_curY state --- } - -layoutSetCommentCol - :: (MonadMultiState LayoutState m) => m () -layoutSetCommentCol = do - state <- mGet - let col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state - traceLocal ("layoutSetCommentCol", col) - unless (Data.Maybe.isJust $ _lstate_commentCol state) - $ mSet state { _lstate_commentCol = Just col } - --- This is also used to move to non-comments in a couple of places. Seems --- to be harmless so far.. -layoutMoveToCommentPos - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Int - -> Int - -> Int - -> m () -layoutMoveToCommentPos y x commentLines = do - traceLocal ("layoutMoveToCommentPos", y, x, commentLines) - state <- mGet - mSet state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right{} -> Right y - , _lstate_addSepSpace = - Just $ if Data.Maybe.isJust (_lstate_commentCol state) - then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = - Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state - , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 - } - --- | does _not_ add spaces to again reach the current base column. -layoutWriteNewline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => m () -layoutWriteNewline = do - traceLocal ("layoutWriteNewline") - state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing - } - -_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () -_layoutResetCommentNewlines = do - mModify $ \state -> state { _lstate_commentNewlines = 0 } - -layoutWriteEnsureNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => m () -layoutWriteEnsureNewlineBlock = do - traceLocal ("layoutWriteEnsureNewlineBlock") - state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing - } - -layoutWriteEnsureAbsoluteN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Int - -> m () -layoutWriteEnsureAbsoluteN n = do - state <- mGet - let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c , _ ) -> n - c - (Nothing, Left i ) -> n - i - (Nothing, Right{}) -> n - traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) - when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to - -- at least (Just 1), so we won't - -- overwrite any old value in any - -- bad way. - } - -layoutBaseYPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () -layoutBaseYPushInternal i = do - traceLocal ("layoutBaseYPushInternal", i) - mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } - -layoutBaseYPopInternal - :: (MonadMultiState LayoutState m) => m () -layoutBaseYPopInternal = do - traceLocal ("layoutBaseYPopInternal") - mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } - -layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () -layoutIndentLevelPushInternal i = do - traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } - -layoutIndentLevelPopInternal - :: (MonadMultiState LayoutState m) => m () -layoutIndentLevelPopInternal = do - traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } - -layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () -layoutRemoveIndentLevelLinger = do - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - } - -layoutWithAddBaseCol - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader Config m - ) - => m () - -> m () -layoutWithAddBaseCol m = do - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - m - layoutBaseYPopInternal - -layoutWithAddBaseColBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader Config m - ) - => m () - -> m () -layoutWithAddBaseColBlock m = do - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - layoutWriteEnsureBlock - m - layoutBaseYPopInternal - -layoutWithAddBaseColNBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Int - -> m () - -> m () -layoutWithAddBaseColNBlock amount m = do - traceLocal ("layoutWithAddBaseColNBlock", amount) - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - layoutWriteEnsureBlock - m - layoutBaseYPopInternal - -layoutWriteEnsureBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => m () -layoutWriteEnsureBlock = do - traceLocal ("layoutWriteEnsureBlock") - state <- mGet - let - diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i ) -> lstate_baseY state - i - (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i ) -> max sp (lstate_baseY state - i) - (Just sp, Right{}) -> max sp (lstate_baseY state) - -- when (diff>0) $ layoutWriteNewlineBlock - when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just $ diff } - -layoutWithAddBaseColN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Int - -> m () - -> m () -layoutWithAddBaseColN amount m = do - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - m - layoutBaseYPopInternal - -layoutBaseYPushCur - :: (MonadMultiState LayoutState m) => m () -layoutBaseYPushCur = do - traceLocal ("layoutBaseYPushCur") - state <- mGet - case _lstate_commentCol state of - Nothing -> - case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> layoutBaseYPushInternal (i + j) - (Left i , Nothing) -> layoutBaseYPushInternal i - (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state - Just cCol -> layoutBaseYPushInternal cCol - -layoutBaseYPop - :: (MonadMultiState LayoutState m) => m () -layoutBaseYPop = do - traceLocal ("layoutBaseYPop") - layoutBaseYPopInternal - -layoutIndentLevelPushCur - :: (MonadMultiState LayoutState m) => m () -layoutIndentLevelPushCur = do - traceLocal ("layoutIndentLevelPushCur") - state <- mGet - let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> i + j - (Left i , Nothing) -> i - (Right{}, Just j ) -> j - (Right{}, Nothing) -> 0 - layoutIndentLevelPushInternal y - -layoutIndentLevelPop - :: (MonadMultiState LayoutState m) => m () -layoutIndentLevelPop = do - traceLocal ("layoutIndentLevelPop") - layoutIndentLevelPopInternal - -- why are comment indentations relative to the previous indentation on - -- the first node of an additional indentation, and relative to the outer - -- indentation after the last node of some indented stuff? sure does not - -- make sense. - layoutRemoveIndentLevelLinger - -layoutAddSepSpace :: (MonadMultiState LayoutState m) - => m () -layoutAddSepSpace = do - state <- mGet - mSet $ state - { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } - --- TODO: when refactoring is complete, the other version of this method --- can probably be removed. -moveToExactAnn - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => AnnKey - -> m () -moveToExactAnn annKey = do - traceLocal ("moveToExactAnn", annKey) - anns <- mAsk - case Map.lookup annKey anns of - Nothing -> return () - Just ann -> do - -- curY <- mGet <&> _lstate_curY - let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann - -- mModify $ \state -> state { _lstate_addNewline = Just x } - moveToY y - -moveToY :: MonadMultiState LayoutState m => Int -> m () -moveToY y = mModify $ \state -> - let upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then - _lstate_commentCol state - <|> _lstate_addSepSpace state - <|> Just (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } --- fixMoveToLineByIsNewline :: MonadMultiState --- LayoutState m => Int -> m Int --- fixMoveToLineByIsNewline x = do --- newLineState <- mGet <&> _lstate_isNewline --- return $ if newLineState == NewLineStateYes --- then x-1 --- else x - -ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m - => ExactPrint.DeltaPos - -> m () -ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do - replicateM_ x $ mTell $ Text.Builder.fromString "\n" - replicateM_ y $ mTell $ Text.Builder.fromString " " - --- TODO: update and use, or clean up. Currently dead code. -layoutWritePriorComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Located ast - -> m () -layoutWritePriorComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns - } - return mAnn - case mAnn of - Nothing -> return () - Just priors -> do - unless (null priors) $ layoutSetCommentCol - priors `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment - --- TODO: update and use, or clean up. Currently dead code. --- this currently only extracs from the `annsDP` field of Annotations. --- per documentation, this seems sufficient, as the --- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Located ast -> m () -layoutWritePostComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns - } - return mAnn - case mAnn of - Nothing -> return () - Just posts -> do - unless (null posts) $ layoutSetCommentCol - posts `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment - -layoutIndentRestorePostComment - :: ( MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - ) - => m () -layoutIndentRestorePostComment = do - state <- mGet - let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state - mModify $ \s -> s { _lstate_commentCol = Nothing - , _lstate_commentNewlines = 0 - } - case (mCommentCol, eCurYAddNL) of - (Just commentCol, Left{}) -> do - layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) - _ -> return () - --- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, --- MonadMultiWriter Text.Builder.Builder m, --- MonadMultiState LayoutState m --- , MonadMultiWriter (Seq String) m) --- => Located ast -> m () --- layoutWritePriorCommentsRestore x = do --- layoutWritePriorComments x --- layoutIndentRestorePostComment --- --- layoutWritePostCommentsRestore :: (Data.Data.Data ast, --- MonadMultiWriter Text.Builder.Builder m, --- MonadMultiState LayoutState m --- , MonadMultiWriter (Seq String) m) --- => Located ast -> m () --- layoutWritePostCommentsRestore x = do --- layoutWritePostComments x --- layoutIndentRestorePostComment diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Config where - -import qualified Data.Bool as Bool -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Coerce (coerce) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Semigroup as Semigroup -import qualified Data.Yaml -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances () -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Utils -import qualified System.Console.CmdArgs.Explicit as CmdArgs -import qualified System.Directory -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath -import qualified System.IO -import UI.Butcher.Monadic - --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } -staticDefaultConfig :: Config -staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False - , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False - } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) - , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline - , _econf_omit_output_valid_check = coerce False - } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort - , _ppconf_hackAroundIncludes = coerce False - } - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } - -forwardOptionsSyntaxExtsEnabled :: ForwardOptions -forwardOptionsSyntaxExtsEnabled = ForwardOptions - { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] - } - --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } -cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) -cmdlineConfigParser = do - -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") - dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") - dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") - dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") - dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") - dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") - dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") - dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") - - return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar - , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty - } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty - , _lconfig_experimentalSemicolonNewlines = mempty - -- , _lconfig_allowSinglelineRecord = mempty - } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty - , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck - } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } - , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate - } - where - falseToNothing = Bool.bool Nothing (Just True) - wrapLast :: Maybe a -> Maybe (Semigroup.Last a) - wrapLast = fmap Semigroup.Last - optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Maybe (f a) - optionConcat = mconcat . fmap (pure . pure) - --- configParser :: Parser Config --- configParser = Config --- <$> option (eitherReader $ maybe (Left "required !") Right . readMaybe) --- (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level") --- <*> (Bar --- <$> switch (long "bara" <> help "bara help") --- <*> switch (long "barb") --- <*> flag 3 5 (long "barc") --- ) --- --- configParserInfo :: ParserInfo Config --- configParserInfo = ParserInfo --- { infoParser = configParser --- , infoFullDesc = True --- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" --- , infoHeader = return $ PP.text "brittany" --- , infoFooter = empty --- , infoFailureCode = (-55) --- , infoIntersperse = True --- } - - --- | Reads a config from a file. If the file does not exist, returns --- Nothing. If the file exists and parsing fails, prints to stderr and --- aborts the MaybeT. Otherwise succeed via Just. --- If the second parameter is True and the file does not exist, writes the --- staticDefaultConfig to the file. -readConfig - :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe)) -readConfig path = do - -- TODO: probably should catch IOErrors and then omit the existence check. - exists <- liftIO $ System.Directory.doesFileExist path - if exists - then do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither' contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) - mzero - Right x -> return x - return $ Just fileConf - else return $ Nothing - --- | Looks for a user-global config file and return its path. --- If there is no global config in a system, one will be created. -userConfigPath :: IO System.IO.FilePath -userConfigPath = do - userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" - let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith Directory.doesFileExist - searchDirs - "config.yaml" - maybe (writeUserConfig userBritPathXdg) pure globalConfig - where - writeUserConfig dir = do - let createConfPath = dir FilePath. "config.yaml" - liftIO $ Directory.createDirectoryIfMissing True dir - writeDefaultConfig $ createConfPath - pure createConfPath - --- | Searches for a local (per-project) brittany config starting from a given directory -findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) -findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir - -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] - let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) - Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" - --- | Reads specified configs. -readConfigs - :: CConfig Maybe -- ^ Explicit options, take highest priority - -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first - -> MaybeT IO Config -readConfigs cmdlineConfig configPaths = do - configs <- readConfig `mapM` configPaths - let merged = Semigroup.sconcat - $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) - return $ cZipWith fromOptionIdentity staticDefaultConfig merged - --- | Reads provided configs --- but also applies the user default configuration (with lowest priority) -readConfigsWithUserConfig - :: CConfig Maybe -- ^ Explicit options, take highest priority - -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first - -> MaybeT IO Config -readConfigsWithUserConfig cmdlineConfig configPaths = do - defaultPath <- liftIO $ userConfigPath - readConfigs cmdlineConfig (configPaths ++ [defaultPath]) - -writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () -writeDefaultConfig path = - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Just . runIdentity) - staticDefaultConfig - -showConfigYaml :: Config -> String -showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap - (\(Identity x) -> Just x) diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Haskell.Brittany.Internal.Config.Types where - -import Data.CZipWith -import Data.Coerce (Coercible, coerce) -import Data.Data (Data) -import qualified Data.Semigroup as Semigroup -import Data.Semigroup (Last) -import Data.Semigroup.Generic -import GHC.Generics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils () - - - -confUnpack :: Coercible a b => Identity a -> b -confUnpack (Identity x) = coerce x - -data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - } - deriving (Generic) - -data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. - , _lconfig_indentPolicy :: f (Last IndentPolicy) - , _lconfig_indentAmount :: f (Last Int) - , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," - -- when creating zero-indentation - -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) - -- ^ for import statement layouting, column at which to align the - -- elements to be imported from a module. - -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) - -- ^ for import statement layouting, column at which put the module's - -- "as" name (which also affects the positioning of the "as" keyword). - -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) - , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) - -- roughly speaking, this sets an upper bound to the number of spaces - -- inserted to create horizontal alignment. - -- More specifically, if 'xs' are the widths of the columns in some - -- alignment-block, then the block will be aligned with the width - -- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ]. - , _lconfig_alignmentBreakOnMultiline :: f (Last Bool) - -- stops alignment between items that are not layouted as a single line. - -- e.g. for single-line alignment, things remain unchanged: - -- do - -- short <- stuff - -- loooooooong <- stuff - -- but not in cases such as: - -- do - -- short <- some more stuff - -- that requires two lines - -- loooooooong <- stuff - , _lconfig_hangingTypeSignature :: f (Last Bool) - -- Do not put "::" in a new line, and use hanging indentation for the - -- signature, i.e.: - -- func :: SomeLongStuff - -- -> SomeLongStuff - -- instead of the usual - -- func - -- :: SomeLongStuff - -- -> SomeLongStuff - -- As usual for hanging indentation, the result will be - -- context-sensitive (in the function name). - , _lconfig_reformatModulePreamble :: f (Last Bool) - -- whether the module preamble/header (module keyword, name, export list, - -- import statements) are reformatted. If false, only the elements of the - -- module (everything past the "where") are reformatted. - , _lconfig_allowSingleLineExportList :: f (Last Bool) - -- if true, and it fits in a single line, and there are no comments in the - -- export list, the following layout will be used: - -- > module MyModule (abc, def) where - -- > [stuff] - -- otherwise, the multi-line version is used: - -- > module MyModule - -- > ( abc - -- > , def - -- > ) - -- > where - , _lconfig_allowHangingQuasiQuotes :: f (Last Bool) - -- if false, the layouter sees any splices as infinitely big and places - -- them accordingly (in newlines, most likely); This also influences - -- parent nodes. - -- if true, the layouter is free to start a quasi-quotation at the end - -- of a line. - -- - -- false: - -- > let - -- > body = - -- > [json| - -- > hello - -- > |] - -- - -- true: - -- > let body = [json| - -- > hello - -- > |] - , _lconfig_experimentalSemicolonNewlines :: f (Last Bool) - -- enables an experimental feature to turn semicolons in brace notation - -- into newlines when using layout: - -- - -- > do { a ;; b } - -- - -- turns into - -- > do - -- > a - -- > - -- > b - -- - -- The implementation for this is a bit hacky and not tested; it might - -- break output syntax or not work properly for every kind of brace. So - -- far I have considered `do` and `case-of`. - -- , _lconfig_allowSinglelineRecord :: f (Last Bool) - -- -- if true, layouts record data decls as a single line when possible, e.g. - -- -- > MyPoint { x :: Double, y :: Double } - -- -- if false, always use the multi-line layout - -- -- > MyPoint - -- -- > { x :: Double - -- -- > , y :: Double - -- -- > } - } - deriving (Generic) - -data CForwardOptions f = ForwardOptions - { _options_ghc :: f [String] - } - deriving (Generic) - -data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) - -- ^ Determines when to fall back on the exactprint'ed output when - -- syntactical constructs are encountered which are not yet handled by - -- brittany. - -- Note that the "risky" setting is risky because even with the check of - -- the syntactic validity of the brittany output, at least in theory there - -- may be cases where the output is syntactically/semantically valid but - -- has different semantics than the code pre-transformation. - , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) - } - deriving (Generic) - -data CPreProcessorConfig f = PreProcessorConfig - { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) - , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) - } - deriving (Generic) - -data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f - , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f - , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - -- ^ this field is somewhat of a duplicate of the one in DebugConfig. - -- It is used for per-declaration disabling by the inline config - -- implementation. Could have re-used the existing field, but felt risky - -- to use a "debug" labeled field for non-debug functionality. - , _conf_disable_formatting :: f (Semigroup.Last Bool) - -- ^ Used for inline config that disables brittany entirely for this - -- module. Useful for wildcard application - -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something - -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) - - } - deriving (Generic) - -type DebugConfig = CDebugConfig Identity -type LayoutConfig = CLayoutConfig Identity -type ForwardOptions = CForwardOptions Identity -type ErrorHandlingConfig = CErrorHandlingConfig Identity -type Config = CConfig Identity - --- i wonder if any Show1 stuff could be leveraged. -deriving instance Show (CDebugConfig Identity) -deriving instance Show (CLayoutConfig Identity) -deriving instance Show (CErrorHandlingConfig Identity) -deriving instance Show (CForwardOptions Identity) -deriving instance Show (CPreProcessorConfig Identity) -deriving instance Show (CConfig Identity) - -deriving instance Show (CDebugConfig Maybe) -deriving instance Show (CLayoutConfig Maybe) -deriving instance Show (CErrorHandlingConfig Maybe) -deriving instance Show (CForwardOptions Maybe) -deriving instance Show (CPreProcessorConfig Maybe) -deriving instance Show (CConfig Maybe) - -deriving instance Data (CDebugConfig Identity) -deriving instance Data (CLayoutConfig Identity) -deriving instance Data (CErrorHandlingConfig Identity) -deriving instance Data (CForwardOptions Identity) -deriving instance Data (CPreProcessorConfig Identity) -deriving instance Data (CConfig Identity) - -deriving instance Data (CDebugConfig Maybe) -deriving instance Data (CLayoutConfig Maybe) -deriving instance Data (CErrorHandlingConfig Maybe) -deriving instance Data (CForwardOptions Maybe) -deriving instance Data (CPreProcessorConfig Maybe) -deriving instance Data (CConfig Maybe) - -instance Semigroup.Semigroup (CDebugConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CConfig Maybe) where - (<>) = gmappend - -instance Semigroup.Semigroup (CDebugConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CConfig Identity) where - (<>) = gmappend - -instance Monoid (CDebugConfig Maybe) where - mempty = gmempty -instance Monoid (CLayoutConfig Maybe) where - mempty = gmempty -instance Monoid (CErrorHandlingConfig Maybe) where - mempty = gmempty -instance Monoid (CForwardOptions Maybe) where - mempty = gmempty -instance Monoid (CPreProcessorConfig Maybe) where - mempty = gmempty -instance Monoid (CConfig Maybe) where - mempty = gmempty - - -data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more - -- than old indentation + amount - | IndentPolicyFree -- can create new indentations whereever - | IndentPolicyMultiple -- can create indentations only - -- at any n * amount. - deriving (Eq, Show, Generic, Data) - -data AltChooser = AltChooserSimpleQuick -- always choose last alternative. - -- leads to tons of sparsely filled - -- lines. - | AltChooserShallowBest -- choose the first matching alternative - -- using the simplest spacing - -- information for the children. - | AltChooserBoundedSearch Int - -- choose the first matching alternative - -- using a bounded list of recursive - -- options having sufficient space. - deriving (Show, Generic, Data) - -data ColumnAlignMode - = ColumnAlignModeDisabled - -- ^ Make no column alignments whatsoever - | ColumnAlignModeUnanimously - -- ^ Make column alignments only if it does not cause overflow for any of - -- the affected lines. - | ColumnAlignModeMajority Float - -- ^ If at least (ratio::Float) of the aligned elements have sufficient - -- space for the alignment, act like ColumnAlignModeAnimously; otherwise - -- act like ColumnAlignModeDisabled. - | ColumnAlignModeAnimouslyScale Int - -- ^ Scale back columns to some degree if their sum leads to overflow. - -- This is done in a linear fashion. - -- The Int specifies additional columns to be added to column maximum for - -- scaling calculation purposes. - | ColumnAlignModeAnimously - -- ^ Decide on a case-by-case basis if alignment would cause overflow. - -- If it does, cancel all alignments for this (nested) column description. - -- ColumnAlignModeAnimouslySome -- potentially to implement - | ColumnAlignModeAlways - -- ^ Always respect column alignments, even if it makes stuff overflow. - deriving (Show, Generic, Data) - -data CPPMode = CPPModeAbort -- abort program on seeing -XCPP - | CPPModeWarn -- warn about CPP and non-roundtripping in its - -- presence. - | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is - -- file.) - deriving (Show, Generic, Data) - -data ExactPrintFallbackMode - = ExactPrintFallbackModeNever -- never fall back on exactprinting - | ExactPrintFallbackModeInline -- fall back only if there are no newlines in - -- the exactprint'ed output. - | ExactPrintFallbackModeRisky -- fall back even in the presence of newlines. - -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF - -- A PROGRAM BY TRANSFORMING IT. - deriving (Show, Generic, Data) - -deriveCZipWith ''CDebugConfig -deriveCZipWith ''CLayoutConfig -deriveCZipWith ''CErrorHandlingConfig -deriveCZipWith ''CForwardOptions -deriveCZipWith ''CPreProcessorConfig -deriveCZipWith ''CConfig - -instance CFunctor CDebugConfig -instance CFunctor CLayoutConfig -instance CFunctor CErrorHandlingConfig -instance CFunctor CForwardOptions -instance CFunctor CPreProcessorConfig -instance CFunctor CConfig diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- These optimizations are disabled to improve compile times (and compilation --- memory usage). When we do not disable them, the CI servers take more than --- 10 minutes to compile this module alone. --- Having looked into aeson and how the instances are written, I still do --- not understand what makes GHC choke so much here. The size of the raw --- expressions below looks fairly negligible, so there must be some expansion --- due to inlining going on. But even disabling INLINE pragmas in aeson did --- not seem to change anything. --- Nonetheless, this solution works and has no downsides because the --- instances defined here are not in any way performance-critical. -{-# OPTIONS_GHC -fno-pre-inlining #-} -{-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fignore-interface-pragmas #-} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Config.Types.Instances where - -import qualified Data.Aeson.Key as Key -import qualified Data.Aeson.Types as Aeson -import Data.Yaml -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude - - - -aesonDecodeOptionsBrittany :: Aeson.Options -aesonDecodeOptionsBrittany = Aeson.defaultOptions - { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (=='_') - } - -instance FromJSON (CDebugConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CDebugConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON IndentPolicy where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON IndentPolicy where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON AltChooser where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON AltChooser where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON ColumnAlignMode where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON ColumnAlignMode where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON CPPMode where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON CPPMode where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON ExactPrintFallbackMode where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON ExactPrintFallbackMode where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON (CLayoutConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CLayoutConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON (CErrorHandlingConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CErrorHandlingConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON (CForwardOptions Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CForwardOptions Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON (CPreProcessorConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CPreProcessorConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance ToJSON (CConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - --- This custom instance ensures the "omitNothingFields" behaviour not only for --- leafs, but for nodes of the config as well. This way e.g. "{}" is valid --- config file content. -instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = Config - <$> v .:? Key.fromString "conf_version" - <*> v .:?= Key.fromString "conf_debug" - <*> v .:?= Key.fromString "conf_layout" - <*> v .:?= Key.fromString "conf_errorHandling" - <*> v .:?= Key.fromString "conf_forward" - <*> v .:?= Key.fromString "conf_preprocessor" - <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" - <*> v .:? Key.fromString "conf_disable_formatting" - <*> v .:? Key.fromString "conf_obfuscate" - parseJSON invalid = Aeson.typeMismatch "Config" invalid - --- Pretends that the value is {} when the key is not present. -(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a -o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.ExactPrintUtils where - -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.Data -import qualified Data.Foldable as Foldable -import qualified Data.Generics as SYB -import Data.HList.HList -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import GHC (GenLocated(L)) -import qualified GHC hiding (parseModule) -import qualified GHC.Driver.CmdLine as GHC -import GHC.Hs -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.SrcLoc (Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified System.IO - - - -parseModule - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule args fp dynCheck = do - str <- System.IO.readFile fp - parseModuleFromString args fp dynCheck str - -parseModuleFromString - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> String - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModuleFromString = ParseModule.parseModule - - -commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () -commentAnnFixTransformGlob ast = do - let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` - (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) - let nodes = SYB.everything (<>) extract ast - let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] - nodes `forM_` (snd .> processComs annsMap) - where - processComs annsMap annKey1 = do - mAnn <- State.Class.gets fst <&> Map.lookup annKey1 - mAnn `forM_` \ann1 -> do - let priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 - let - processCom - :: (ExactPrint.Comment, ExactPrint.DeltaPos) - -> ExactPrint.TransformT Identity Bool - processCom comPair@(com, _) = - case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of - comLoc -> case Map.lookupLE comLoc annsMap of - Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of - (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> - move $> False - (x, y) | x == y -> move $> False - _ -> return True - where - ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 - ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 - move = ExactPrint.modifyAnnsT $ \anns -> - let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns - ann2' = ann2 - { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] - } - in - Map.insert annKey2 ann2' anns - _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors - follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case - (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let ann1' = ann1 { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } - ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns - - --- TODO: this is unused by now, but it contains one detail that --- commentAnnFixTransformGlob does not include: Moving of comments for --- "RecordUpd"s. --- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () --- commentAnnFixTransform modul = SYB.everything (>>) genF modul --- where --- genF :: Data.Data.Data a => a -> ExactPrint.Transform () --- genF = (\_ -> return ()) `SYB.extQ` exprF --- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () --- exprF lexpr@(L _ expr) = case expr of --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> --- #else --- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordUpd _ _e fs@(_:_) -> --- #else --- RecordUpd _e fs@(_:_) _cons _ _ _ -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- _ -> return () - --- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () --- commentAnnFixTransform modul = SYB.everything (>>) genF modul --- where --- genF :: Data.Data.Data a => a -> ExactPrint.Transform () --- genF = (\_ -> return ()) `SYB.extQ` exprF --- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () --- exprF lexpr@(L _ expr) = case expr of --- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> --- moveTrailingComments lexpr (List.last fs) --- RecordUpd _ _e fs@(_:_) -> --- moveTrailingComments lexpr (List.last fs) --- _ -> return () - --- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) --- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () --- moveTrailingComments astFrom astTo = do --- let --- k1 = ExactPrint.mkAnnKey astFrom --- k2 = ExactPrint.mkAnnKey astTo --- moveComments ans = ans' --- where --- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans --- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans --- cs1f = ExactPrint.annFollowingComments an1 --- cs2f = ExactPrint.annFollowingComments an2 --- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) --- $ \case --- (ExactPrint.AnnComment com, dp) -> Left (com, dp) --- x -> Right x --- an1' = an1 --- { ExactPrint.annsDP = nonComments --- , ExactPrint.annFollowingComments = [] --- } --- an2' = an2 --- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments --- } --- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - --- ExactPrint.modifyAnnsT moveComments - --- | split a set of annotations in a module into a map from top-level module --- elements to the relevant annotations. Avoids quadratic behaviour a trivial --- implementation would have. -extractToplevelAnns - :: Located HsModule - -> ExactPrint.Anns - -> Map ExactPrint.AnnKey ExactPrint.Anns -extractToplevelAnns lmod anns = output - where - (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod - declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap1 = Map.unions $ ldecls <&> \ldecl -> - Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) - declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap2 = - Map.fromList - $ [ (captured, declMap1 Map.! k) - | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns - ] - declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns - -groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) -groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) - Map.empty - where - insert k a Nothing = Just (Map.singleton k a) - insert k a (Just m) = Just (Map.insert k a m) - -foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey -foldedAnnKeys ast = SYB.everything - Set.union - ( \x -> maybe - Set.empty - Set.singleton - [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x - | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) - , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x - -- for some reason, ghc-8.8 has forgotten how to infer the type of l, - -- even though it is passed to mkAnnKey above, which only accepts - -- SrcSpan. - ] - ) - ast - where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) - - -withTransformedAnns - :: Data ast - => ast - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case - readers@(conf :+: anns :+: HNil) -> do - -- TODO: implement `local` for MultiReader/MultiRWS - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - x <- m - MultiRWSS.mPutRawR readers - pure x - where - f anns = - let ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced - - -warnExtractorCompat :: GHC.Warn -> String -warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ /dev/null @@ -1,781 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.LayouterBasics where - -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Writer.Strict as Writer -import qualified Data.Char as Char -import Data.Data -import qualified Data.Map as Map -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import DataTreePrint -import GHC (GenLocated(L), Located, moduleName, moduleNameString) -import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.Name (getOccString) -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader (RdrName(..)) -import qualified GHC.Types.SrcLoc as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - - - -processDefault - :: ( ExactPrint.Annotate.Annotate ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiReader ExactPrint.Types.Anns m - ) - => Located ast - -> m () -processDefault x = do - anns <- mAsk - let str = ExactPrint.exactPrint x anns - -- this hack is here so our print-empty-module trick does not add - -- a newline at the start if there actually is no module header / imports - -- / anything. - -- TODO: instead the appropriate annotation could be removed when "cleaning" - -- the module (header). This would remove the need for this hack! - case str of - "\n" -> return () - _ -> mTell $ Text.Builder.fromString str - --- | Use ExactPrint's output for this node; add a newly generated inline comment --- at insertion position (meant to point out to the user that this node is --- not handled by brittany yet). Useful when starting implementing new --- syntactic constructs when children are not handled yet. -briDocByExact - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ToBriDocM BriDocNumbered -briDocByExact ast = do - anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - docExt ast anns True - --- | Use ExactPrint's output for this node. --- Consider that for multi-line input, the indentation of the code produced --- by ExactPrint might be different, and even incompatible with the indentation --- of its surroundings as layouted by brittany. But there are safe uses of --- this, e.g. for any top-level declarations. -briDocByExactNoComment - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ToBriDocM BriDocNumbered -briDocByExactNoComment ast = do - anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - docExt ast anns False - --- | Use ExactPrint's output for this node, presuming that this output does --- not contain any newlines. If this property is not met, the semantics --- depend on the @econf_AllowRiskyExactPrintUse@ config flag. -briDocByExactInlineOnly - :: (ExactPrint.Annotate.Annotate ast) - => String - -> Located ast - -> ToBriDocM BriDocNumbered -briDocByExactInlineOnly infoStr ast = do - anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns - fallbackMode <- - mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t - let errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit - $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" - case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _ ) -> errorAction - (_ , [t]) -> exactPrintNode - (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) - (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted - _ -> errorAction - -rdrNameToText :: RdrName -> Text --- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr -rdrNameToText (Unqual occname) = Text.pack $ occNameString occname -rdrNameToText (Qual mname occname) = - Text.pack $ moduleNameString mname ++ "." ++ occNameString occname -rdrNameToText (Orig modul occname) = - Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname -rdrNameToText (Exact name) = Text.pack $ getOccString name - -lrdrNameToText :: GenLocated l RdrName -> Text -lrdrNameToText (L _ n) = rdrNameToText n - -lrdrNameToTextAnnGen - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => (Text -> Text) - -> Located RdrName - -> m Text -lrdrNameToTextAnnGen f ast@(L _ n) = do - anns <- mAsk - let t = f $ rdrNameToText n - let hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False - -- TODO: in general: we should _always_ process all annotaiton stuff here. - -- whatever we don't probably should have had some effect on the - -- output. in such cases, resorting to byExact is probably the safe - -- choice. - return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" - _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t - -lrdrNameToTextAnn - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName - -> m Text -lrdrNameToTextAnn = lrdrNameToTextAnnGen id - -lrdrNameToTextAnnTypeEqualityIsSpecial - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName - -> m Text -lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - lrdrNameToTextAnnGen f ast - --- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects --- the annotations for a (parent) node for a tick to be added to the --- literal. --- Excessively long name to reflect on us having to work around such --- excessively obscure special cases in the exactprint API. -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick - :: ( Data ast - , MonadMultiReader Config m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => Located ast - -> Located RdrName - -> m Text -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do - hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - return $ if hasQuote then Text.cons '\'' lit else lit - -askIndent :: (MonadMultiReader Config m) => m Int -askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk - - -extractAllComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] -extractAllComments ann = - ExactPrint.annPriorComments ann ++ extractRestComments ann - -extractRestComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] -extractRestComments ann = - ExactPrint.annFollowingComments ann - ++ (ExactPrint.annsDP ann >>= \case - (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] - ) - -filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) - --- | True if there are any comments that are --- a) connected to any node below (in AST sense) the given node AND --- b) after (in source code order) the node. -hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsBelow ast@(L l _) = - List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) - <$> astConnectedComments ast - -hasCommentsBetween - :: Data ast - => GHC.Located ast - -> AnnKeywordId - -> AnnKeywordId - -> ToBriDocM Bool -hasCommentsBetween ast leftKey rightKey = do - mAnn <- astAnn ast - let go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest - case mAnn of - Nothing -> pure False - Just ann -> pure $ go1 $ ExactPrint.annsDP ann - --- | True if there are any comments that are connected to any node below (in AST --- sense) the given node -hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast - --- | True if there are any regular comments connected to any node below (in AST --- sense) the given node -hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsConnected ast = - any isRegularComment <$> astConnectedComments ast - --- | Regular comments are comments that are actually "source code comments", --- i.e. things that start with "--" or "{-". In contrast to comment-annotations --- used by ghc-exactprint for capturing symbols (and their exact positioning). --- --- Only the type instance layouter makes use of this filter currently, but --- it might make sense to apply it more aggressively or make it the default - --- I believe that most of the time we branch on the existence of comments, we --- only care about "regular" comments. We simply did not need the distinction --- because "irregular" comments are not that common outside of type/data decls. -isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool -isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst - -astConnectedComments - :: Data ast - => GHC.Located ast - -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] -astConnectedComments ast = do - anns <- filterAnns ast <$> mAsk - pure $ extractAllComments =<< Map.elems anns - -hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsPrior ast = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors - -hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsRest ast = astAnn ast <&> \case - Nothing -> False - Just ann -> any isRegularComment (extractRestComments ann) - -hasAnnKeywordComment - :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just ann -> any hasK (extractAllComments ann) - where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst - -hasAnnKeyword - :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) - => Located a - -> AnnKeywordId - -> m Bool -hasAnnKeyword ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks - where - hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - -astAnn - :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) - => GHC.Located ast - -> m (Maybe Annotation) -astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk - --- new BriDoc stuff - -allocateNode - :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered -allocateNode bd = do - i <- allocNodeIndex - return (i, bd) - -allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int -allocNodeIndex = do - NodeAllocIndex i <- mGet - mSet $ NodeAllocIndex (i + 1) - return i - --- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docEmpty = allocateNode BDFEmpty --- --- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered --- docLit t = allocateNode $ BDFLit t --- --- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) --- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered --- docExt x anns shouldAddComment = allocateNode $ BDFExternal --- (ExactPrint.Types.mkAnnKey x) --- (foldedAnnKeys x) --- shouldAddComment --- (Text.pack $ ExactPrint.exactPrint x anns) --- --- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docAlt l = allocateNode . BDFAlt =<< sequence l --- --- --- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docSeq l = allocateNode . BDFSeq =<< sequence l --- --- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docLines l = allocateNode . BDFLines =<< sequence l --- --- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered --- docCols sig l = allocateNode . BDFCols sig =<< sequence l --- --- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered --- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm --- --- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm --- --- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm --- --- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docSeparator = allocateNode BDFSeparator --- --- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered --- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm --- --- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered --- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm --- --- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm --- --- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- appSep x = docSeq [x, docSeparator] --- --- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docCommaSep = appSep $ docLit $ Text.pack "," --- --- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docParenLSep = appSep $ docLit $ Text.pack "(" --- --- --- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) --- => Located ast --- -> m BriDocNumbered --- -> m BriDocNumbered --- docPostComment ast bdm = do --- bd <- bdm --- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd --- --- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) --- => Located ast --- -> m BriDocNumbered --- -> m BriDocNumbered --- docWrapNode ast bdm = do --- bd <- bdm --- i1 <- allocNodeIndex --- i2 <- allocNodeIndex --- return --- $ (,) i1 --- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) --- $ (,) i2 --- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) --- $ bd --- --- docPar :: MonadMultiState NodeAllocIndex m --- => m BriDocNumbered --- -> m BriDocNumbered --- -> m BriDocNumbered --- docPar lineM indentedM = do --- line <- lineM --- indented <- indentedM --- allocateNode $ BDFPar BrIndentNone line indented --- --- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm --- --- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm --- --- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered --- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd - -docEmpty :: ToBriDocM BriDocNumbered -docEmpty = allocateNode BDFEmpty - -docLit :: Text -> ToBriDocM BriDocNumbered -docLit t = allocateNode $ BDFLit t - -docLitS :: String -> ToBriDocM BriDocNumbered -docLitS s = allocateNode $ BDFLit $ Text.pack s - -docExt - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ExactPrint.Types.Anns - -> Bool - -> ToBriDocM BriDocNumbered -docExt x anns shouldAddComment = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey x) - (foldedAnnKeys x) - shouldAddComment - (Text.pack $ ExactPrint.exactPrint x anns) - -docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docAlt l = allocateNode . BDFAlt =<< sequence l - -newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) - deriving (Functor, Applicative, Monad) - -addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = - when cond (addAlternative doc) - -addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = - CollectAltM . Writer.tell . (: []) - -runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered -runFilteredAlternative (CollectAltM action) = - docAlt $ Writer.execWriter action - - -docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docSeq [] = docEmpty -docSeq l = allocateNode . BDFSeq =<< sequence l - -docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docLines l = allocateNode . BDFLines =<< sequence l - -docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docCols sig l = allocateNode . BDFCols sig =<< sequence l - -docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm - -docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetBaseY bdm = do - bd <- bdm - -- the order here is important so that these two nodes can be treated - -- properly over at `transformAlts`. - n1 <- allocateNode $ BDFBaseYPushCur bd - n2 <- allocateNode $ BDFBaseYPop n1 - return n2 - -docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetIndentLevel bdm = do - bd <- bdm - n1 <- allocateNode $ BDFIndentLevelPushCur bd - n2 <- allocateNode $ BDFIndentLevelPop n1 - return n2 - -docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetBaseAndIndent = docSetBaseY . docSetIndentLevel - -docSeparator :: ToBriDocM BriDocNumbered -docSeparator = allocateNode BDFSeparator - -docAnnotationPrior - :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationPrior annKey bdm = - allocateNode . BDFAnnotationPrior annKey =<< bdm - -docAnnotationKW - :: AnnKey - -> Maybe AnnKeywordId - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm - -docMoveToKWDP - :: AnnKey - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docMoveToKWDP annKey kw shouldRestoreIndent bdm = - allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm - -docAnnotationRest - :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm - -docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm - -docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm - -docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm - -docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm - -docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docDebug s bdm = allocateNode . BDFDebug s =<< bdm - -appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -appSep x = docSeq [x, docSeparator] - -docCommaSep :: ToBriDocM BriDocNumbered -docCommaSep = appSep $ docLit $ Text.pack "," - -docParenLSep :: ToBriDocM BriDocNumbered -docParenLSep = appSep docParenL - --- TODO: we don't make consistent use of these (yet). However, I think the --- most readable approach overall might be something else: define --- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. --- I think those two would make the usage most readable. --- lit "(" and appSep (lit "(") are understandable and short without --- introducing a new top-level binding for all types of parentheses. -docParenL :: ToBriDocM BriDocNumbered -docParenL = docLit $ Text.pack "(" - -docParenR :: ToBriDocM BriDocNumbered -docParenR = docLit $ Text.pack ")" - -docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] - -docParenHashRSep :: ToBriDocM BriDocNumbered -docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] - -docBracketL :: ToBriDocM BriDocNumbered -docBracketL = docLit $ Text.pack "[" - -docBracketR :: ToBriDocM BriDocNumbered -docBracketR = docLit $ Text.pack "]" - - -docTick :: ToBriDocM BriDocNumbered -docTick = docLit $ Text.pack "'" - -docNodeAnnKW - :: Data.Data.Data ast - => Located ast - -> Maybe AnnKeywordId - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docNodeAnnKW ast kw bdm = - docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm - -docNodeMoveToKWDP - :: Data.Data.Data ast - => Located ast - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm - -class DocWrapable a where - docWrapNode :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - docWrapNodePrior :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - docWrapNodeRest :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - -instance DocWrapable (ToBriDocM BriDocNumbered) where - docWrapNode ast bdm = do - bd <- bdm - i1 <- allocNodeIndex - i2 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd - docWrapNodePrior ast bdm = do - bd <- bdm - i1 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ bd - docWrapNodeRest ast bdm = do - bd <- bdm - i2 <- allocNodeIndex - return - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd - -instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where - docWrapNode ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNode ast bd] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> - [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] - _ -> error "cannot happen (TM)" - docWrapNodePrior ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNodePrior ast bd] - (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR - docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR - -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where - docWrapNode ast bdsm = do - bds <- bdsm - case bds of - [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. - [bd] -> do - bd' <- docWrapNode ast (return bd) - return [bd'] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do - bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) - return $ [bd1'] ++ reverse bdM ++ [bdN'] - _ -> error "cannot happen (TM)" - docWrapNodePrior ast bdsm = do - bds <- bdsm - case bds of - [] -> return [] - (bd1:bdR) -> do - bd1' <- docWrapNodePrior ast (return bd1) - return (bd1':bdR) - docWrapNodeRest ast bdsm = do - bds <- bdsm - case reverse bds of - [] -> return [] - (bdN:bdR) -> do - bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN':bdR) - -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where - docWrapNode ast bdsm = do - bds <- bdsm - case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. - bd1 Seq.:< rest -> case Seq.viewr rest of - Seq.EmptyR -> do - bd1' <- docWrapNode ast (return bd1) - return $ Seq.singleton bd1' - bdM Seq.:> bdN -> do - bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) - return $ (bd1' Seq.<| bdM) Seq.|> bdN' - docWrapNodePrior ast bdsm = do - bds <- bdsm - case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty - bd1 Seq.:< bdR -> do - bd1' <- docWrapNodePrior ast (return bd1) - return $ bd1' Seq.<| bdR - docWrapNodeRest ast bdsm = do - bds <- bdsm - case Seq.viewr bds of - Seq.EmptyR -> return Seq.empty - bdR Seq.:> bdN -> do - bdN' <- docWrapNodeRest ast (return bdN) - return $ bdR Seq.|> bdN' - -instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where - docWrapNode ast stuffM = do - (bds, bd, x) <- stuffM - if null bds - then do - bd' <- docWrapNode ast (return bd) - return (bds, bd', x) - else do - bds' <- docWrapNodePrior ast (return bds) - bd' <- docWrapNodeRest ast (return bd) - return (bds', bd', x) - docWrapNodePrior ast stuffM = do - (bds, bd, x) <- stuffM - bds' <- docWrapNodePrior ast (return bds) - return (bds', bd, x) - docWrapNodeRest ast stuffM = do - (bds, bd, x) <- stuffM - bd' <- docWrapNodeRest ast (return bd) - return (bds, bd', x) - - - -docPar - :: ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docPar lineM indentedM = do - line <- lineM - indented <- indentedM - allocateNode $ BDFPar BrIndentNone line indented - -docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm - -docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm - -docEnsureIndent - :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd - -unknownNodeError - :: Data.Data.Data ast - => String - -> GenLocated GHC.SrcSpan ast - -> ToBriDocM BriDocNumbered -unknownNodeError infoStr ast = do - mTell [ErrorUnknownNode infoStr ast] - docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" - -spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] -spacifyDocs [] = [] -spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] - -briDocMToPPM :: ToBriDocM a -> PPMLocal a -briDocMToPPM m = do - (x, errs, debugs) <- briDocMToPPMInner m - mTell debugs - mTell errs - return x - -briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) -briDocMToPPMInner m = do - readers <- MultiRWSS.mGetRawR - let ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m - pure (x, errs, debugs) - -docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) -docSharedWrapper f x = return <$> f x diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ /dev/null @@ -1,437 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.DataDecl where - -import qualified Data.Data -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L), Located) -import qualified GHC -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - -layoutDataDecl - :: Located (TyClDecl GhcPs) - -> Located RdrName - -> LHsQTyVars GhcPs - -> HsDataDefn GhcPs - -> ToBriDocM BriDocNumbered -layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of - -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> - docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl - - - -- data MyData a b - -- (zero constructors) - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> - docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "data" - , lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - ] - - -- data MyData = MyData .. - -- data MyData = MyData { .. } - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> - case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> - docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of - Nothing -> pure Nothing - Just x -> Just . pure <$> x - rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing - Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- return <$> createDetailsDoc consNameStr details - consDoc <- fmap pure - $ docNonBottomSpacing - $ case (forallDocMay, rhsContextDocMay) of - (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] - , docSeq - [ docLitS "." - , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] - ] - ] - (Just forallDoc, Nothing) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] - , docSeq [docLitS ".", docSeparator, rhsDoc] - ] - (Nothing, Just rhsContextDoc) -> docSeq - [ docLitS "=" - , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] - ] - (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] - createDerivingPar mDerivs $ docAlt - [ -- data D = forall a . Show a => D a - docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline $ lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - ] - , docLitS "=" - , docSeparator - , docSetIndentLevel $ docSeq - [ case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc - ] - ] - , -- data D - -- = forall a . Show a => D a - docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline lhsContextDoc - , appSep $ docLit nameStr - , tyVarLine - ] - ) - ( docSeq - [ docLitS "=" - , docSeparator - , docSetIndentLevel $ docSeq - [ case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc - ] - ] - ) - , -- data D - -- = forall a - -- . Show a => - -- D a - docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline lhsContextDoc - , appSep $ docLit nameStr - , tyVarLine - ] - ) - consDoc - , -- data - -- Show a => - -- D - -- = forall a - -- . Show a => - -- D a - -- This alternative is only for -XDatatypeContexts. - -- But I think it is rather unlikely this will trigger without - -- -XDataTypeContexts, especially with the `docNonBottomSpacing` - -- above, so while not strictly necessary, this should not - -- hurt. - docAddBaseY BrIndentRegular $ docPar - (docLitS "data") - ( docLines - [ lhsContextDoc - , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLit nameStr - , tyVarLine - ] - , consDoc - ] - ) - ] - _ -> briDocByExactNoComment ltycl - - _ -> briDocByExactNoComment ltycl - -createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered -createContextDoc [] = docEmpty -createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] -createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 - tRDocs <- tR `forM` docSharedWrapper layoutType - docAlt - [ docSeq - [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse docCommaSep - (t1Doc : tRDocs) - , docLitS ") =>" - , docSeparator - ] - , docLines $ join - [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs - <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] - , [docLitS ") =>", docSeparator] - ] - ] - -createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered -createBndrDoc bs = do - tyVarDocs <- bs `forM` \case - (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar _ _ext lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] - -createDerivingPar - :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -createDerivingPar derivs mainDoc = do - case derivs of - (L _ []) -> mainDoc - (L _ types) -> - docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc - <$> types - -derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of - (L _ []) -> docSeq [] - (L _ ts) -> - let - tsLength = length ts - whenMoreThan1Type val = - if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in - docSeq - [ docDeriving - , docWrapNodePrior types $ lhsStrategy - , docSeparator - , whenMoreThan1Type "(" - , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts <&> \case - HsIB _ t -> layoutType t - , whenMoreThan1Type ")" - , rhsStrategy - ] - where - strategyLeftRight = \case - (L _ StockStrategy ) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes) ) -> - ( docEmpty - , case viaTypes of - HsIB _ext t -> docSeq - [ docWrapNode lVia $ docLitS " via" - , docSeparator - , layoutType t - ] - ) - -docDeriving :: ToBriDocM BriDocNumbered -docDeriving = docLitS "deriving" - -createDetailsDoc - :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) -createDetailsDoc consNameStr details = case details of - PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let - singleLine = docSeq - [ docLit consNameStr - , docSeparator - , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ fmap hsScaledThing args <&> layoutType - ] - leftIndented = docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType <$> fmap hsScaledThing args - multiAppended = docSeq - [ docLit consNameStr - , docSeparator - , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args - ] - multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - (docLit consNameStr) - (docLines $ layoutType <$> fmap hsScaledThing args) - case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] - IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] - IndentPolicyFree -> - docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_:_)) -> do - let ((fName1, fType1) : fDocR) = mkFieldDocs fields - -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack - let allowSingleline = False - docAddBaseY BrIndentRegular - $ runFilteredAlternative - $ do - -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" - ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 - , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 - ] - , docSeq - [ docLitS "{" - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) - ] - ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType - ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] - , docLitS "}" - ] - ) - InfixCon arg1 arg2 -> docSeq - [ layoutType $ hsScaledThing arg1 - , docSeparator - , docLit consNameStr - , docSeparator - , layoutType $ hsScaledThing arg2 - ] - where - mkFieldDocs - :: [LConDeclField GhcPs] - -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] - mkFieldDocs = fmap $ \lField -> case lField of - L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t - -createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = Just $ docSeq - [docLitS "forall ", createBndrDoc lhsTyVarBndrs] - -createNamesAndTypeDoc - :: Data.Data.Data ast - => Located ast - -> [GenLocated t (FieldOcc GhcPs)] - -> Located (HsType GhcPs) - -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -createNamesAndTypeDoc lField names t = - ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \case - L _ (FieldOcc _ fieldName) -> - docLit =<< lrdrNameToTextAnn fieldName - ] - , docWrapNodeRest lField $ layoutType t - ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ /dev/null @@ -1,975 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.Layouters.Decl where - -import qualified Data.Data -import qualified Data.Foldable -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Data.Bag (bagToList, emptyBag) -import qualified GHC.Data.FastString as FastString -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic - ( Activation(..) - , InlinePragma(..) - , InlineSpec(..) - , LexicalFixity(..) - , RuleMatchInfo(..) - ) -import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint - - - -layoutDecl :: ToBriDoc HsDecl -layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) - ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD _ (TyFamInstD _ tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False d tfid - InstD _ (ClsInstD _ inst) -> - withTransformedAnns d $ layoutClsInst (L loc inst) - _ -> briDocByExactNoComment d - --------------------------------------------------------------------------------- --- Sig --------------------------------------------------------------------------------- - -layoutSig :: ToBriDoc Sig -layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ - InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> - docWrapNode lsig $ do - nameStr <- lrdrNameToTextAnn name - specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " - docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) - <> nameStr - <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ - _ -> briDocByExactNoComment lsig -- TODO - where - layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] - nameStrs <- names `forM` lrdrNameToTextAnn - let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- mAsk - <&> _conf_layout - .> _lconfig_hangingTypeSignature - .> confUnpack - if shouldBeHanging - then docSeq $ - [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ] - ] - else layoutLhsAndType - hasComments - (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) - "::" - typeDoc - -specStringCompat - :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String -specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " - -layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) -layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body - BindStmt _ lPat expr -> do - patDoc <- docSharedWrapper layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docCols ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO - - --------------------------------------------------------------------------------- --- HsBind --------------------------------------------------------------------------------- - -layoutBind - :: ToBriDocC - (HsBindLR GhcPs GhcPs) - (Either [BriDocNumbered] BriDocNumbered) -layoutBind lbind@(L _ bind) = case bind of - FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" - funcPatDocs <- - docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches - return $ Left $ funcPatDocs - PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat - clauseDocs <- layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" - hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments - PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID - lpat - dir - rpat - _ -> Right <$> unknownNodeError "" lbind -layoutIPBind :: ToBriDoc IPBind -layoutIPBind lipbind@(L _ bind) = case bind of - IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" - IPBind _ (Left (L _ (HsIPName name))) expr -> do - ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name - binderDoc <- docLit $ Text.pack "=" - exprDoc <- layoutExpr expr - hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments - - -data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) - | BagSig (LSig GhcPs) - -bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan -bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l - -layoutLocalBinds - :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) -layoutLocalBinds lbinds@(L _ binds) = case binds of - -- HsValBinds (ValBindsIn lhsBindsLR []) -> - -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering - -- x@(HsValBinds (ValBindsIn{})) -> - -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x - HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered - docs <- docWrapNode lbinds $ join <$> ordered `forM` \case - BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s - return $ Just $ docs --- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> - HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> - Just <$> mapM layoutIPBind bb - EmptyLocalBinds{} -> return $ Nothing - --- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is --- parSpacing stuff.B -layoutGrhs - :: LGRHS GhcPs (LHsExpr GhcPs) - -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) -layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do - guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body - return (guardDocs, bodyDoc, body) - -layoutPatternBind - :: Maybe Text - -> BriDocNumbered - -> LMatch GhcPs (LHsExpr GhcPs) - -> ToBriDocM BriDocNumbered -layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match - let (GRHSs _ grhss whereBinds) = m_grhss match - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p - let isInfix = isInfixMatch match - mIdStr <- case match of - Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId - _ -> pure Nothing - let mIdStr' = fixPatternBindIdentifier match <$> mIdStr - patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1:p2:pr) | isInfix -> if null pr - then - docCols ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else - docCols ColPatternsFuncInfix - ( [docCols ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR - ] - ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) - (Just idStr, []) -> docLit idStr - (Just idStr, ps) -> - docCols ColPatternsFuncPrefix - $ appSep (docLit $ idStr) - : (spacifyDocs $ docForceSingleline <$> ps) - (Nothing, ps) -> - docCols ColPatterns - $ (List.intersperse docSeparator $ docForceSingleline <$> ps) - clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) - let alignmentToken = if null pats then Nothing else funId - hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments - -fixPatternBindIdentifier - :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text -fixPatternBindIdentifier match idStr = go $ m_ctxt match - where - go = \case - (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr - (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1 ) -> goInner ctx1 - _ -> idStr - -- I have really no idea if this path ever occurs, but better safe than - -- risking another "drop bangpatterns" bugs. - goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 - (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr - -layoutPatternBindFinal - :: Maybe Text - -> BriDocNumbered - -> Maybe BriDocNumbered - -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) - -- ^ AnnKey for the node that contains the AnnWhere position annotation - -> Bool - -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do - let patPartInline = case mPatDoc of - Nothing -> [] - Just patDoc -> [appSep $ docForceSingleline $ return patDoc] - patPartParWrap = case mPatDoc of - Nothing -> id - Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- mAsk - <&> _conf_layout - .> _lconfig_indentWhereSpecial - .> confUnpack - regularIndentAmount <- mAsk - <&> _conf_layout - .> _lconfig_indentAmount - .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt - [ docEnsureIndent BrIndentRegular - $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty - [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse docCommaSep - (docForceSingleline . return <$> gs) - ) - wherePart = case mWhereDocs of - Nothing -> Just docEmpty - Just (_, [w]) -> Just $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> Nothing - - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack - - runFilteredAlternative $ do - - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' - ] - ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine - - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1:gr) -> - ( docSeq [appSep $ docLit $ Text.pack "|", return g1] - : ( gr - <&> \g -> - docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - --- | Layout a pattern synonym binding -layoutPatSynBind - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) - -> HsPatSynDir GhcPs - -> LPat GhcPs - -> ToBriDocM BriDocNumbered -layoutPatSynBind name patSynDetails patDir rpat = do - let patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" - mWhereDocs <- layoutPatSynWhere patDir - headDoc <- fmap pure $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] - runFilteredAlternative $ do - addAlternative $ - -- pattern .. where - -- .. - -- .. - docAddBaseY BrIndentRegular $ docSeq - ( [headDoc, docSeparator, body] - ++ case mWhereDocs of - Just ds -> [docSeparator, docPar whereDoc (docLines ds)] - Nothing -> [] - ) - addAlternative $ - -- pattern .. = - -- .. - -- pattern .. <- - -- .. where - -- .. - -- .. - docAddBaseY BrIndentRegular $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) - ) - --- | Helper method for the left hand side of a pattern synonym -layoutLPatSyn - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) - -> ToBriDocM BriDocNumbered -layoutLPatSyn name (PrefixCon vars) = do - docName <- lrdrNameToTextAnn name - names <- mapM lrdrNameToTextAnn vars - docSeq . fmap appSep $ docLit docName : (docLit <$> names) -layoutLPatSyn name (InfixCon left right) = do - leftDoc <- lrdrNameToTextAnn left - docName <- lrdrNameToTextAnn name - rightDoc <- lrdrNameToTextAnn right - docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] -layoutLPatSyn name (RecCon recArgs) = do - docName <- lrdrNameToTextAnn name - args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq . fmap docLit - $ [docName, Text.pack " { " ] - <> intersperse (Text.pack ", ") args - <> [Text.pack " }"] - --- | Helper method to get the where clause from of explicitly bidirectional --- pattern synonyms -layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) -layoutPatSynWhere hs = case hs of - ExplicitBidirectional (MG _ (L _ lbinds) _) -> do - binderDoc <- docLit $ Text.pack "=" - Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds - _ -> pure Nothing - --------------------------------------------------------------------------------- --- TyClDecl --------------------------------------------------------------------------------- - -layoutTyCl :: ToBriDoc TyClDecl -layoutTyCl ltycl@(L _loc tycl) = case tycl of - SynDecl _ name vars fixity typ -> do - let isInfix = case fixity of - Prefix -> False - Infix -> True - -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP - -- let parenWrapper = if hasTrailingParen - -- then appSep . docWrapNodeRest ltycl - -- else id - let wrapNodeRest = docWrapNodeRest ltycl - docWrapNodePrior ltycl - $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ - DataDecl _ext name tyVars _ dataDefn -> - layoutDataDecl ltycl name tyVars dataDefn - _ -> briDocByExactNoComment ltycl - -layoutSynDecl - :: Bool - -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) - -> Located (IdP GhcPs) - -> [LHsTyVarBndr () GhcPs] - -> LHsType GhcPs - -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix wrapNodeRest name vars typ = do - nameStr <- lrdrNameToTextAnn name - let - lhs = appSep . wrapNodeRest $ if isInfix - then do - let (a : b : rest) = vars - hasOwnParens <- hasAnnKeywordComment a AnnOpenP - -- This isn't quite right, but does give syntactically valid results - let needsParens = not (null rest) || hasOwnParens - docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - ] - ++ [ docParenL | needsParens ] - ++ [ layoutTyVarBndr False a - , docSeparator - , docLit nameStr - , docSeparator - , layoutTyVarBndr False b - ] - ++ [ docParenR | needsParens ] - ++ fmap (layoutTyVarBndr True) rest - else - docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] - ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsConnected typ - layoutLhsAndType hasComments sharedLhs "=" typeDoc - -layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) -layoutTyVarBndr needsSep lbndr@(L _ bndr) = do - docWrapNodePrior lbndr $ case bndr of - UserTyVar _ _ name -> do - nameStr <- lrdrNameToTextAnn name - docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] - KindedTyVar _ _ name kind -> do - nameStr <- lrdrNameToTextAnn name - docSeq - $ [ docSeparator | needsSep ] - ++ [ docLit $ Text.pack "(" - , appSep $ docLit nameStr - , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind - , docLit $ Text.pack ")" - ] - - --------------------------------------------------------------------------------- --- TyFamInstDecl --------------------------------------------------------------------------------- - - - -layoutTyFamInstDecl - :: Data.Data.Data a - => Bool - -> Located a - -> TyFamInstDecl GhcPs - -> ToBriDocM BriDocNumbered -layoutTyFamInstDecl inClass outerNode tfid = do - let - FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid - -- bndrsMay isJust e.g. with - -- type instance forall a . MyType (Maybe a) = Either () a - innerNode = outerNode - docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name - needsParens <- hasAnnKeyword outerNode AnnOpenP - let - instanceDoc = if inClass - then docLit $ Text.pack "type" - else docSeq - [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] - makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered - makeForallDoc bndrs = do - bndrDocs <- layoutTyVarBndrs bndrs - docSeq - ( [docLit (Text.pack "forall")] - ++ processTyVarBndrsSingleline bndrDocs - ) - lhs = - docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] - ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] - ++ [ docParenL | needsParens ] - ++ [appSep $ docWrapNode name $ docLit nameStr] - ++ intersperse docSeparator (layoutHsTyPats pats) - ++ [ docParenR | needsParens ] - hasComments <- (||) - <$> hasAnyRegularCommentsConnected outerNode - <*> hasAnyRegularCommentsRest innerNode - typeDoc <- docSharedWrapper layoutType typ - layoutLhsAndType hasComments lhs "=" typeDoc - - -layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] -layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm - HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] - -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change - -- is a bit strange. Hopefully this does not ignore any important - -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" - --------------------------------------------------------------------------------- --- ClsInstDecl --------------------------------------------------------------------------------- - --- | Layout an @instance@ declaration --- --- Layout signatures and bindings using the corresponding layouters from the --- top-level. Layout the instance head, type family instances, and data family --- instances using ExactPrint. -layoutClsInst :: ToBriDoc ClsInstDecl -layoutClsInst lcid@(L _ cid) = docLines - [ layoutInstanceHead - , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) - ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) - ] - where - layoutInstanceHead :: ToBriDocM BriDocNumbered - layoutInstanceHead = - briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren - <$> lcid - - removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs - removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] - , cid_datafam_insts = [] - } - - -- | Like 'docLines', but sorts the lines based on location - docSortedLines - :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered - docSortedLines l = - allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l - - layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) - layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig - - layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) - layoutAndLocateBind lbind@(L loc _) = - L loc <$> (joinBinds =<< layoutBind lbind) - - joinBinds - :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered - joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n - - layoutAndLocateTyFamInsts - :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateTyFamInsts ltfid@(L loc tfid) = - L loc <$> layoutTyFamInstDecl True ltfid tfid - - layoutAndLocateDataFamInsts - :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateDataFamInsts ldfid@(L loc _) = - L loc <$> layoutDataFamInstDecl ldfid - - -- | Send to ExactPrint then remove unecessary whitespace - layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl - layoutDataFamInstDecl ldfid = - fmap stripWhitespace <$> briDocByExactNoComment ldfid - - -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations - stripWhitespace :: BriDocF f -> BriDocF f - stripWhitespace (BDFExternal ann anns b t) = - BDFExternal ann anns b $ stripWhitespace' t - stripWhitespace b = b - - -- | This fixes two issues of output coming from Exactprinting - -- associated (data) type decls. Firstly we place the output into docLines, - -- so one newline coming from Exactprint is superfluous, so we drop the - -- first (empty) line. The second issue is Exactprint indents the first - -- member in a strange fashion: - -- - -- input: - -- - -- > instance MyClass Int where - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- output of just exactprinting the associated data type syntax node - -- - -- > - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- To fix this, we strip whitespace from the start of the comments and the - -- first line of the declaration, stopping when we see "data" or "type" at - -- the start of a line. I.e., this function yields - -- - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- Downside apart from being a hacky and brittle fix is that this removes - -- possible additional indentation from comments before the first member. - -- - -- But the whole thing is just a temporary measure until brittany learns - -- to layout data/type decls. - stripWhitespace' :: Text -> Text - stripWhitespace' t = - Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t - where - go [] = [] - go (line1 : lineR) = case Text.stripStart line1 of - st | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR - isTypeOrData t' = - (Text.pack "type" `Text.isPrefixOf` t') - || (Text.pack "newtype" `Text.isPrefixOf` t') - || (Text.pack "data" `Text.isPrefixOf` t') - - --------------------------------------------------------------------------------- --- Common Helpers --------------------------------------------------------------------------------- - -layoutLhsAndType - :: Bool - -> ToBriDocM BriDocNumbered - -> String - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -layoutLhsAndType hasComments lhs sep typeDoc = do - runFilteredAlternative $ do - -- (separators probably are "=" or "::") - -- lhs = type - -- lhs :: type - addAlternativeCond (not hasComments) $ docSeq - [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] - -- lhs - -- :: typeA - -- -> typeB - -- lhs - -- = typeA - -- -> typeB - addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols - ColTyOpPrefix - [ appSep $ docLitS sep - , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc - ] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ /dev/null @@ -1,1078 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Expr where - -import qualified Data.Data -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) -import qualified GHC.Data.FastString as FastString -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Types.Name -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -layoutExpr :: ToBriDoc HsExpr -layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack - let allowFreeIndent = indentPolicy == IndentPolicyFree - docWrapNode lexpr $ case expr of - HsVar _ vname -> do - docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> - docLit $ Text.pack $ occNameString oname - HsRecFld{} -> do - -- TODO - briDocByExactInlineOnly "HsRecFld" lexpr - HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '#' : label - HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '?' : label - HsOverLit _ olit -> do - allocateNode $ overLitValBriDoc $ ol_val olit - HsLit _ lit -> do - allocateNode $ litBriDoc lit - HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds {} <- llocals - , L _ (GRHS _ [] body) <- lgrhs - -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let shouldPrefixSeparator = case p of - L _ LazyPat{} -> isFirst - L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let funcPatternPartLine = - docCols ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing - $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> - unknownNodeError "HsLam too complex" lexpr - HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing $ docAddBaseY BrIndentRegular $ - (docLit $ Text.pack "\\case {}") - HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "\\case") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r:list) l - x -> (x, list) - let (headE, paramEs) = gather [exp2] exp1 - let colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq - headDoc <- docSharedWrapper layoutExpr headE - paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - hasComments <- hasAnyCommentsConnected exp2 - runFilteredAlternative $ do - -- foo x y - addAlternativeCond (not hasComments) - $ colsOrSequence - $ appSep (docForceSingleline headDoc) - : spacifyDocs (docForceSingleline <$> paramDocs) - -- foo x - -- y - addAlternativeCond allowFreeIndent - $ docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ docForceSingleline <$> paramDocs - ] - -- foo - -- x - -- y - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline headDoc) - ( docNonBottomSpacing - $ docLines paramDocs - ) - -- ( multi - -- line - -- function - -- ) - -- x - -- y - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - headDoc - ( docNonBottomSpacing - $ docLines paramDocs - ) - HsApp _ exp1 exp2 -> do - -- TODO: if expDoc1 is some literal, we may want to create a docCols here. - expDoc1 <- docSharedWrapper layoutExpr exp1 - expDoc2 <- docSharedWrapper layoutExpr exp2 - docAlt - [ -- func arg - docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] - , -- func argline1 - -- arglines - -- e.g. - -- func Abc - -- { member1 = True - -- , member2 = 13 - -- } - docSetParSpacing -- this is most likely superfluous because - -- this is a sequence of a one-line and a par-space - -- anyways, so it is _always_ par-spaced. - $ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docForceSingleline expDoc1 - , docForceParSpacing expDoc2 - ] - , -- func - -- arg - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline expDoc1) - (docNonBottomSpacing expDoc2) - , -- fu - -- nc - -- ar - -- gument - docAddBaseY BrIndentRegular - $ docPar - expDoc1 - expDoc2 - ] - HsAppType _ exp1 (HsWC _ ty1) -> do - t <- docSharedWrapper layoutType ty1 - e <- docSharedWrapper layoutExpr exp1 - docAlt - [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar - e - (docSeq [docLit $ Text.pack "@", t ]) - ] - OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft - leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight - allowSinglelinePar <- do - hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp - pure $ not hasComLeft && not hasComOp - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - runFilteredAlternative $ do - -- > one + two + three - -- or - -- > one + two + case x of - -- > _ -> three - addAlternativeCond allowSinglelinePar - $ docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - -- this case rather leads to some unfortunate layouting than to anything - -- useful; disabling for now. (it interfers with cols stuff.) - -- addAlternative - -- $ docSetBaseY - -- $ docPar - -- leftOperandDoc - -- ( docLines - -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - -- ) - -- > one - -- > + two - -- > + three - addAlternative $ - docPar - leftOperandDoc - ( docLines - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - ) - OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp - expDocRight <- docSharedWrapper layoutExpr expRight - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False - runFilteredAlternative $ do - -- one-line - addAlternative - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceSingleline expDocRight - ] - -- -- line + freely indented block for right expression - -- addAlternative - -- $ docSeq - -- [ appSep $ docForceSingleline expDocLeft - -- , appSep $ docForceSingleline expDocOp - -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight - -- ] - -- two-line - addAlternative $ do - let - expDocOpAndRight = docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight - -- TODO: in both cases, we don't force expDocLeft to be - -- single-line, which has certain.. interesting consequences. - -- At least, the "two-line" label is not entirely - -- accurate. - -- one-line + par - addAlternativeCond allowPar - $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceParSpacing expDocRight - ] - -- more lines - addAlternative $ do - let expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight - NegApp _ op _ -> do - opDoc <- docSharedWrapper layoutExpr op - docSeq [ docLit $ Text.pack "-" - , opDoc - ] - HsPar _ innerExp -> do - innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp - docAlt - [ docSeq - [ docLit $ Text.pack "(" - , docForceSingleline innerExpDoc - , docLit $ Text.pack ")" - ] - , docSetBaseY $ docLines - [ docCols ColOpPrefix - [ docLit $ Text.pack "(" - , docAddBaseY (BrIndentSpecial 2) innerExpDoc - ] - , docLit $ Text.pack ")" - ] - ] - SectionL _ left op -> do -- TODO: add to testsuite - leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op - docSeq [leftDoc, docSeparator, opDoc] - SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op - rightDoc <- docSharedWrapper layoutExpr right - docSeq [opDoc, docSeparator, rightDoc] - ExplicitTuple _ args boxity -> do - let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e); - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs - $ docSharedWrapper - $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- orM - ( hasCommentsBetween lexpr AnnOpenP AnnCloseP - : map hasAnyCommentsBelow args - ) - let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) - case splitFirstLast argDocs of - FirstLastEmpty -> docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) closeLit - ] - FirstLastSingleton e -> docAlt - [ docCols ColTuple - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - , closeLit - ] - , docSetBaseY $ docLines - [ docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - ] - , closeLit - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] - ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] - addAlternative $ - let - start = docCols ColTuples - [appSep openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] - HsCase _ cExp (MG _ (L _ []) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - docAlt - [ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] - , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") - ] - HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches - docAlt - [ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of" - ]) - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "of") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) - ) - ] - HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr - thenExprDoc <- docSharedWrapper layoutExpr thenExpr - elseExprDoc <- docSharedWrapper layoutExpr elseExpr - hasComments <- hasAnyCommentsBelow lexpr - let maySpecialIndent = - case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 - -- TODO: some of the alternatives (especially last and last-but-one) - -- overlap. - docSetIndentLevel $ runFilteredAlternative $ do - -- if _ then _ else _ - addAlternativeCond (not hasComments) - $ docSeq - [ appSep $ docLit $ Text.pack "if" - , appSep $ docForceSingleline ifExprDoc - , appSep $ docLit $ Text.pack "then" - , appSep $ docForceSingleline thenExprDoc - , appSep $ docLit $ Text.pack "else" - , docForceSingleline elseExprDoc - ] - -- either - -- if expr - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if expr - -- then - -- stuff - -- else - -- stuff - -- note that this has par-spacing - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - -- either - -- if multi - -- line - -- condition - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if multi - -- line - -- condition - -- then - -- stuff - -- else - -- stuff - -- note that this does _not_ have par-spacing - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - addAlternative - $ docSetBaseY - $ docLines - [ docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" - hasComments <- hasAnyCommentsBelow lexpr - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "if") - (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) - HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 - -- We jump through some ugly hoops here to ensure proper sharing. - hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds - let - ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = - case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x - -- this `docSetBaseAndIndent` might seem out of place (especially the - -- Indent part; setBase is necessary due to the use of docLines below), - -- but is here due to ghc-exactprint's DP handling of "let" in - -- particular. - -- Just pushing another indentation level is a straightforward approach - -- to making brittany idempotent, even though the result is non-optimal - -- if "let" is moved horizontally as part of the transformation, as the - -- comments before the first let item are moved horizontally with it. - docSetBaseAndIndent $ case mBindDocs of - Just [bindDoc] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) - $ appSep $ docForceSingleline bindDoc - , appSep $ docLit $ Text.pack "in" - , docForceSingleline expDoc1 - ] - addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) - ] - , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY expDoc1) - ] - ] - Just bindDocs@(_:_) -> runFilteredAlternative $ do - --either - -- let - -- a = b - -- c = d - -- in foo - -- bar - -- baz - --or - -- let - -- a = b - -- c = d - -- in - -- fooooooooooooooooooo - let noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular - $ docForceParSpacing expDoc1 - ] - ] - addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds - IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines bindDocs - ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY expDoc1 - ] - ] - addAlternative - $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) - ] - _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] - -- docSeq [appSep $ docLit "let in", expDoc1] - HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of - DoExpr _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - MDoExpr _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ docForceSingleline <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative $ - let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - _ -> do - -- TODO - unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr - hasComments <- hasAnyCommentsBelow lexpr - case splitFirstLast elemDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "[" - , docSeparator - , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e - ] - , docLit $ Text.pack "]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) - ++ [docLit $ Text.pack "]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> - docLit $ Text.pack "[]" - RecordCon _ lname fields -> - case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- fs - `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr - RecordUpd _ rExpr fields -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- fields - `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ case ambName of - Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - recordExpression False indentPolicy lexpr rExprDoc rFs - ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do - expDoc <- docSharedWrapper layoutExpr exp1 - typDoc <- docSharedWrapper layoutType typ1 - docSeq - [ appSep expDoc - , appSep $ docLit $ Text.pack "::" - , typDoc - ] - ArithSeq _ Nothing info -> - case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> - briDocByExactInlineOnly "ArithSeq" lexpr - HsBracket{} -> do - -- TODO - briDocByExactInlineOnly "HsBracket{}" lexpr - HsRnBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsRnBracketOut{}" lexpr - HsTcBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsTcBracketOut{}" lexpr - HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do - allocateNode $ BDFPlain - (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]") - HsSpliceE{} -> do - -- TODO - briDocByExactInlineOnly "HsSpliceE{}" lexpr - HsProc{} -> do - -- TODO - briDocByExactInlineOnly "HsProc{}" lexpr - HsStatic{} -> do - -- TODO - briDocByExactInlineOnly "HsStatic{}" lexpr - HsTick{} -> do - -- TODO - briDocByExactInlineOnly "HsTick{}" lexpr - HsBinTick{} -> do - -- TODO - briDocByExactInlineOnly "HsBinTick{}" lexpr - HsConLikeOut{} -> do - -- TODO - briDocByExactInlineOnly "HsWrap{}" lexpr - ExplicitSum{} -> do - -- TODO - briDocByExactInlineOnly "ExplicitSum{}" lexpr - HsPragE{} -> do - -- TODO - briDocByExactInlineOnly "HsPragE{}" lexpr - -recordExpression - :: (Data.Data.Data lExpr, Data.Data.Data name) - => Bool - -> IndentPolicy - -> GenLocated SrcSpan lExpr - -> ToBriDocM BriDocNumbered - -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] - -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = - docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = - docSeq -- this case might still be incomplete, and is probably not used - -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do - let (rF1f, rF1n, rF1e) = rF1 - runFilteredAlternative $ do - -- container { fieldA = blub, fieldB = blub } - addAlternative - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc - , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr - , if dotdot - then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator - , docLit $ Text.pack "}" - ] - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docSeq - [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ] - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield - $ docCols ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq [ appSep $ docLit $ Text.pack "=" - , docForceParSpacing x - ] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) - -litBriDoc :: HsLit GhcPs -> BriDocFInt -litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - _ -> error "litBriDoc: literal with no SourceText" - -overLitValBriDoc :: OverLitVal -> BriDocFInt -overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsIsString (SourceText t) _ -> BDFLit $ Text.pack t - _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Expr where - -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types - - - -layoutExpr :: ToBriDoc HsExpr - --- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) - -litBriDoc :: HsLit GhcPs -> BriDocFInt - -overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.IE where - -import qualified Data.List.Extra -import qualified Data.Text as Text -import GHC - ( AnnKeywordId(..) - , GenLocated(L) - , Located - , ModuleName - , moduleNameString - , unLoc - ) -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -prepareName :: LIEWrappedName name -> Located name -prepareName = ieLWrappedName - -layoutIE :: ToBriDoc IE -layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of - IEVar _ x -> layoutWrapped lie x - IEThingAbs _ x -> layoutWrapped lie x - IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x (IEWildcard _) _ _ -> - docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x _ ns _ -> do - hasComments <- orM - ( hasCommentsBetween lie AnnOpenP AnnCloseP - : hasAnyCommentsBelow x - : map hasAnyCommentsBelow ns - ) - let sortedNs = List.sortOn wrappedNameToText ns - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc sortedNs) - ++ [docParenR] - addAlternative - $ docWrapNodeRest lie - $ docAddBaseY BrIndentRegular - $ docPar - (layoutWrapped lie x) - (layoutItems (splitFirstLast sortedNs)) - where - nameDoc = docLit <=< lrdrNameToTextAnn . prepareName - layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] - layoutItems FirstLastEmpty = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] - layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] - layoutItems (FirstLast n1 nMs nN) = - docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] - ++ map layoutItem nMs - ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] - IEModuleContents _ n -> docSeq - [ docLit $ Text.pack "module" - , docSeparator - , docLit . Text.pack . moduleNameString $ unLoc n - ] - _ -> docEmpty - where - layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n - L _ (IEPattern n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "pattern " <> name - L _ (IEType n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "type " <> name - -data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted --- Helper function to deal with Located lists of LIEs. --- In particular this will also associate documentation --- from the located list that actually belongs to the last IE. --- It also adds docCommaSep to all but the first element --- This configuration allows both vertical and horizontal --- handling of the resulting list. Adding parens is --- left to the caller since that is context sensitive -layoutAnnAndSepLLIEs - :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] -layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do - let makeIENode ie = docSeq [docCommaSep, ie] - let sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText - $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies - ieCommaDocs <- - docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] - FirstLastSingleton ie -> [ie] - FirstLast ie1 ieMs ieN -> - [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] - pure $ fmap pure ieCommaDocs -- returned shared nodes - where - mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] - mergeGroup items@[_] = items - mergeGroup items = if - | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items - -- proper means that if it is a ThingWith, it does not contain a wildcard - -- (because I don't know what a wildcard means if it is not already a - -- IEThingAll). - isProperIEThing :: LIE GhcPs -> Bool - isProperIEThing = \case - L _ (IEThingAbs _ _wn) -> True - L _ (IEThingAll _ _wn) -> True - L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True - _ -> False - isIEVar :: LIE GhcPs -> Bool - isIEVar = \case - L _ IEVar{} -> True - _ -> False - thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{} ) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 ( L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 - thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) - = L - l - (IEThingWith x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) - ) - thingFolder _ _ = - error "thingFolder should be exhaustive because we have a guard above" - - --- Builds a complete layout for the given located --- list of LIEs. The layout provides two alternatives: --- (item, item, ..., item) --- ( item --- , item --- ... --- , item --- ) --- If the llies contains comments the list will --- always expand over multiple lines, even when empty: --- () -- no comments --- ( -- a comment --- ) -layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered -layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies - hasComments <- hasAnyCommentsBelow llies - runFilteredAlternative $ case ieDs of - [] -> do - addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" - addAlternativeCond hasComments $ docPar - (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH : ieDsT) -> do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] - --- | Returns a "fingerprint string", not a full text representation, nor even --- a source code representation of this syntax node. --- Used for sorting, not for printing the formatter's output source code. -wrappedNameToText :: LIEWrappedName RdrName -> Text -wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n - L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n - --- | Returns a "fingerprint string", not a full text representation, nor even --- a source code representation of this syntax node. --- Used for sorting, not for printing the formatter's output source code. -lieToText :: LIE GhcPs -> Text -lieToText = \case - L _ (IEVar _ wn ) -> wrappedNameToText wn - L _ (IEThingAbs _ wn ) -> wrappedNameToText wn - L _ (IEThingAll _ wn ) -> wrappedNameToText wn - L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn - -- TODO: These _may_ appear in exports! - -- Need to check, and either put them at the top (for module) or do some - -- other clever thing. - L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" - where - moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Import where - -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L), Located, moduleNameString, unLoc) -import GHC.Hs -import GHC.Types.Basic -import GHC.Unit.Types (IsBootInterface(..)) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - -prepPkg :: SourceText -> String -prepPkg rawN = case rawN of - SourceText n -> n - -- This would be odd to encounter and the - -- result will most certainly be wrong - NoSourceText -> "" -prepModName :: Located e -> e -prepModName = unLoc - -layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered -layoutImport importD = case importD of - ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do - importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let - compact = indentPolicy /= IndentPolicyFree - modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies - minQLength = length "import qualified " - qLengthReal = - let qualifiedPart = if q /= NotQualified then length "qualified " else 0 - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal - -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength - importQualifiers = docSeq - [ appSep $ docLit $ Text.pack "import" - , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } - , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty - , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty - , maybe docEmpty (appSep . docLit) pkgNameT - ] - indentName = - if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = - indentName $ appSep $ docLit modNameT - hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 - hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = if hiding - then appSep $ docLit $ Text.pack "hiding" - else docEmpty - importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of - Nothing -> docEmpty - Just (_, llies) -> do - hasComments <- hasAnyCommentsBelow llies - if compact - then docAlt - [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] - , let makeParIfHiding = if hiding - then docAddBaseY BrIndentRegular . docPar hidDoc - else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar - (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - ( docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) - makeAsDoc asT = - docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] - if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular $ - docPar (docSeq [importHead, asDoc]) bindingsD - ] - else - case masT of - Just n -> if enoughRoom - then docLines - [ docSeq [importHead, asDoc], bindingsD] - else docLines [importHead, asDoc, bindingsD] - where - enoughRoom = nameCost < importAsCol - asCost - asDoc = - docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n - Nothing -> if enoughRoom - then docSeq [importHead, bindingsD] - else docLines [importHead, bindingsD] - where enoughRoom = nameCost < importCol - hidingParenCost - _ -> docEmpty diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Module where - -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types - (DeltaPos(..), commentContents, deltaRow) - - - -layoutModule :: ToBriDoc' HsModule -layoutModule lmod@(L _ mod') = case mod' of - -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do - commentedImports <- transformToCommentedImport imports - -- groupify commentedImports `forM_` tellDebugMessShow - docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) - -- sortedImports <- sortImports imports - -- docLines $ [layoutImport y i | (y, i) <- sortedImports] - HsModule _ (Just n) les imports _ _ _ -> do - commentedImports <- transformToCommentedImport imports - -- groupify commentedImports `forM_` tellDebugMessShow - -- sortedImports <- sortImports imports - let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- mAsk - <&> _conf_layout - .> _lconfig_allowSingleLineExportList - .> confUnpack - -- the config should not prevent single-line layout when there is no - -- export list - let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les - docLines - $ docSeq - [ docNodeAnnKW lmod Nothing docEmpty - -- A pseudo node that serves merely to force documentation - -- before the node - , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ - docForceSingleline - $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative - $ docLines - [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docSeq [ - docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) - ] - ] - : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] - -data CommentedImport - = EmptyLine - | IndependentComment (Comment, DeltaPos) - | ImportStatement ImportStatementRecord - -instance Show CommentedImport where - show = \case - EmptyLine -> "EmptyLine" - IndependentComment _ -> "IndependentComment" - ImportStatement r -> - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -data ImportStatementRecord = ImportStatementRecord - { commentsBefore :: [(Comment, DeltaPos)] - , commentsAfter :: [(Comment, DeltaPos)] - , importStatement :: ImportDecl GhcPs - } - -instance Show ImportStatementRecord where - show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -transformToCommentedImport - :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] -transformToCommentedImport is = do - nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do - annotionMay <- astAnn i - pure (annotionMay, rawImport) - let - convertComment (c, DP (y, x)) = - replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] - accumF - :: [(Comment, DeltaPos)] - -> (Maybe Annotation, ImportDecl GhcPs) - -> ([(Comment, DeltaPos)], [CommentedImport]) - accumF accConnectedComm (annMay, decl) = case annMay of - Nothing -> - ( [] - , [ ImportStatement ImportStatementRecord { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } - ] - ) - Just ann -> - let - blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 - (newAccumulator, priorComments') = - List.span ((== 0) . deltaRow . snd) (annPriorComments ann) - go - :: [(Comment, DeltaPos)] - -> [(Comment, DeltaPos)] - -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) - go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) - go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs - go acc ((c1, DP (y, x)) : xs) = - ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine - , (c1, DP (1, x)) : acc - , 0 - ) - (convertedIndependentComments, beforeComments, initialBlanks) = - if blanksBeforeImportDecl /= 0 - then (convertComment =<< priorComments', [], 0) - else go [] (reverse priorComments') - in - ( newAccumulator - , convertedIndependentComments - ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine - ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm - , importStatement = decl - } - ] - ) - let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations - pure $ join $ (convertComment =<< finalAcc) : finalList - -sortCommentedImports :: [CommentedImport] -> [CommentedImport] -sortCommentedImports = - unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify - where - unpackImports :: [CommentedImport] -> [CommentedImport] - unpackImports xs = xs >>= \case - l@EmptyLine -> [l] - l@IndependentComment{} -> [l] - ImportStatement r -> - map IndependentComment (commentsBefore r) ++ [ImportStatement r] - mergeGroups - :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] - mergeGroups xs = xs >>= \case - Left x -> [x] - Right y -> ImportStatement <$> y - sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] - sortGroups = - List.sortOn (moduleNameString . unLoc . ideclName . importStatement) - groupify - :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] - groupify cs = go [] cs - where - go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest - (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] - go acc = \case - (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest - (l@IndependentComment{} : rest) -> - Left l : Right (reverse acc) : go [] rest - (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] - -commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered -commentedImportsToDoc = \case - EmptyLine -> docLitS "" - IndependentComment c -> commentToDoc c - ImportStatement r -> - docSeq - ( layoutImport (importStatement r) - : map commentToDoc (commentsAfter r) - ) - where - commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Pattern where - -import qualified Data.Foldable as Foldable -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import GHC (GenLocated(L), ol_val) -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import Language.Haskell.Brittany.Internal.LayouterBasics -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - --- | layouts patterns (inside function bindings, case alternatives, let --- bindings or do notation). E.g. for input --- > case computation of --- > (warnings, Success a b) -> .. --- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by --- 'layoutPat'. Similarly for --- > func abc True 0 = [] --- ^^^^^^^^^^ this part --- We will use `case .. of` as the imagined prefix to the examples used in --- the different cases below. -layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) -layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" - -- _ -> expr - VarPat _ n -> - fmap Seq.singleton $ docLit $ lrdrNameToText n - -- abc -> expr - LitPat _ lit -> - fmap Seq.singleton $ allocateNode $ litBriDoc lit - -- 0 -> expr - ParPat _ inner -> do - -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" - right <- docLit $ Text.pack ")" - innerDocs <- colsWrapPat =<< layoutPat inner - return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right - -- return $ (left Seq.<| innerDocs) Seq.|> right - -- case Seq.viewl innerDocs of - -- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur.. - -- x1 Seq.:< rest -> case Seq.viewr rest of - -- Seq.EmptyR -> - -- fmap return $ docSeq - -- [ docLit $ Text.pack "(" - -- , return x1 - -- , docLit $ Text.pack ")" - -- ] - -- middle Seq.:> xN -> do - -- x1' <- docSeq [docLit $ Text.pack "(", return x1] - -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] - -- return $ (x1' Seq.<| middle) Seq.|> xN' - ConPat _ lname (PrefixCon args) -> do - -- Abc a b c -> expr - nameDoc <- lrdrNameToTextAnn lname - argDocs <- layoutPat `mapM` args - if null argDocs - then return <$> docLit nameDoc - else do - x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList - $ sequence - $ spacifyDocs - $ fmap colsWrapPat argDocs - return $ x1 Seq.<| xR - ConPat _ lname (InfixCon left right) -> do - -- a :< b -> expr - nameDoc <- lrdrNameToTextAnn lname - leftDoc <- appSep . colsWrapPat =<< layoutPat left - rightDoc <- colsWrapPat =<< layoutPat right - middle <- appSep $ docLit nameDoc - return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc - ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do - -- Abc{} -> expr - let t = lrdrNameToText lname - fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do - -- Abc { a = locA, b = locB, c = locC } -> expr1 - -- Abc { a, b, c } -> expr2 - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName - , docSeparator - , docLit $ Text.pack "}" - ] - ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do - -- Abc { .. } -> expr - let t = lrdrNameToText lname - Seq.singleton <$> docSeq - [ appSep $ docLit t - , docLit $ Text.pack "{..}" - ] - ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do - -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case - (fieldName, Just fieldDoc) -> - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - , docCommaSep - ] - (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] - TuplePat _ args boxity -> do - -- (nestedpat1, nestedpat2, nestedpat3) -> expr - -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr - case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR - Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep - AsPat _ asName asPat -> do - -- bind@nestedpat -> expr - wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") - SigPat _ pat1 (HsPS _ ty1) -> do - -- i :: Int -> expr - patDocs <- layoutPat pat1 - tyDoc <- docSharedWrapper layoutType ty1 - case Seq.viewr patDocs of - Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" - xR Seq.:> xN -> do - xN' <- -- at the moment, we don't support splitting patterns into - -- multiple lines. but we cannot enforce pasting everything - -- into one line either, because the type signature will ignore - -- this if we overflow sufficiently. - -- In order to prevent syntactically invalid results in such - -- cases, we need the AddBaseY here. - -- This can all change when patterns get multiline support. - docAddBaseY BrIndentRegular $ docSeq - [ appSep $ return xN - , appSep $ docLit $ Text.pack "::" - , docForceSingleline tyDoc - ] - return $ xR Seq.|> xN' - ListPat _ elems -> - -- [] -> expr1 - -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 - wrapPatListy elems "[]" docBracketL docBracketR - BangPat _ pat1 -> do - -- !nestedpat -> expr - wrapPatPrepend pat1 (docLit $ Text.pack "!") - LazyPat _ pat1 -> do - -- ~nestedpat -> expr - wrapPatPrepend pat1 (docLit $ Text.pack "~") - NPat _ llit@(L _ ol) mNegative _ -> do - -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol - negDoc <- docLit $ Text.pack "-" - pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] - Nothing -> Seq.singleton litDoc - - _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat - -colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered -colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList - -wrapPatPrepend - :: LPat GhcPs - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR - -wrapPatListy - :: [LPat GhcPs] - -> String - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) -wrapPatListy elems both start end = do - elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) - case Seq.viewl elemDocs of - Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both - x1 Seq.:< rest -> do - sDoc <- start - eDoc <- end - rest' <- rest `forM` \bd -> docSeq - [ docCommaSep - , return bd - ] - return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.Layouters.Stmt where - -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L)) -import GHC.Hs -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) -layoutStmt lstmt@(L _ stmt) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - indentAmount :: Int <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - docWrapNode lstmt $ case stmt of - LastStmt _ body Nothing _ -> do - layoutExpr body - BindStmt _ lPat expr -> do - patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docAlt - [ docCols - ColBindStmt - [ appSep patDoc - , docSeq - [ appSep $ docLit $ Text.pack "<-" - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc - ] - ] - , docCols - ColBindStmt - [ appSep patDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "<-") (expDoc) - ] - ] - LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree - let indentFourPlus = indentAmount >= 4 - layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" - -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAlt - [ -- let bind = expr - docCols - ColDoLet - [ appSep $ docLit $ Text.pack "let" - , let - f = case indentPolicy of - IndentPolicyFree -> docSetBaseAndIndent - IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc - ] - , -- let - -- bind = expr - docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - ] - Just bindDocs -> runFilteredAlternative $ do - -- let aaa = expra - -- bbb = exprb - -- ccc = exprc - addAlternativeCond (isFree || indentFourPlus) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , let f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs - ] - -- let - -- aaa = expra - -- bbb = exprb - -- ccc = exprc - addAlternativeCond (not indentFourPlus) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do - -- rec stmt1 - -- stmt2 - -- stmt3 - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] - -- rec - -- stmt1 - -- stmt2 - -- stmt3 - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docLit (Text.pack "rec")) - (docLines $ layoutStmt <$> stmts) - BodyStmt _ expr _ _ -> do - expDoc <- docSharedWrapper layoutExpr expr - docAddBaseY BrIndentRegular $ expDoc - _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Stmt where - -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types - - - -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ /dev/null @@ -1,643 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Type where - -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Utils.Outputable (ftext, showSDocUnsafe) -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - (FirstLastView(..), splitFirstLast) - - - -layoutType :: ToBriDoc HsType -layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of - -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" - HsTyVar _ promoted name -> do - t <- lrdrNameToTextAnnTypeEqualityIsSpecial name - case promoted of - IsPromoted -> docSeq - [ docSeparator - , docTick - , docWrapNode name $ docLit t - ] - NotPromoted -> docWrapNode name $ docLit t - HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do - let bndrs = getBinders hsf - typeDoc <- docSharedWrapper layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let - tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - forallDoc = docAlt - [ let - open = docLit $ Text.pack "forall" - in docSeq ([open]++tyVarDocLineList) - , docPar - (docLit (Text.pack "forall")) - (docLines - $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ]) - ] - contextDoc = case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) - , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) cntxtDoc - ] - in docPar open $ docLines $ list ++ [close] - ] - docAlt - -- :: forall a b c . (Foo a b c) => a b -> c - [ docSeq - [ if null bndrs - then docEmpty - else let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) - , docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- :: forall a b c - -- . (Foo a b c) - -- => a b - -- -> c - , docPar - forallDoc - ( docLines - [ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) - $ contextDoc - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] - ] - ) - ] - HsForAllTy _ hsf typ2 -> do - let bndrs = getBinders hsf - typeDoc <- layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - docAlt - -- forall x . x - [ docSeq - [ if null bndrs - then docEmpty - else let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open]++tyVarDocLineList++[close]) - , docForceSingleline $ return $ typeDoc - ] - -- :: forall x - -- . x - , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) - -- :: forall - -- (x :: *) - -- . x - , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ] - ) - ++[ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ] - ) - ] - HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do - typeDoc <- docSharedWrapper layoutType typ1 - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - contextDoc = docWrapNode lcntxts $ case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) - , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) - $ head cntxtDocs - ] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) - $ cntxtDoc - ] - in docPar open $ docLines $ list ++ [close] - ] - let maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - docAlt - -- (Foo a b c) => a b -> c - [ docSeq - [ docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- (Foo a b c) - -- => a b - -- -> c - , docPar - (docForceSingleline contextDoc) - ( docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) - ] - HsFunTy _ _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - hasComments <- hasAnyCommentsBelow ltype - docAlt $ - [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 - ] - | not hasComments - ] ++ - [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) - $ maybeForceML typeDoc2 - ] - ) - ] - HsParTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docLit $ Text.pack ")" - ] - , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack ")") - ] - HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 - final -> (final, list) - let (typHead, typRest) = gather [typ2] typ1 - docHead <- docSharedWrapper layoutType typHead - docRest <- docSharedWrapper layoutType `mapM` typRest - docAlt - [ docSeq - $ docForceSingleline docHead : (docRest >>= \d -> - [ docSeparator, docForceSingleline d ]) - , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) - ] - HsAppTy _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - docAlt - [ docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docForceSingleline typeDoc2 - ] - , docPar - typeDoc1 - (docEnsureIndent BrIndentRegular typeDoc2) - ] - HsListTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "[" - , docForceSingleline typeDoc1 - , docLit $ Text.pack "]" - ] - , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack "]") - ] - HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple - HsBoxedOrConstraintTuple -> simple - where - unboxed = if null typs then error "brittany internal error: unboxed unit" - else unboxedL - simple = if null typs then unitL else simpleL - unitL = docLit $ Text.pack "()" - simpleL = do - docs <- docSharedWrapper layoutType `mapM` typs - let end = docLit $ Text.pack ")" - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) - docAlt - [ docSeq $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] - , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) - ] - unboxedL = do - docs <- docSharedWrapper layoutType `mapM` typs - let start = docParenHashLSep - end = docParenHashRSep - docAlt - [ docSeq $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] - , let - line1 = docCols ColTyOpPrefix [start, head docs] - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - in docPar - (docAddBaseY (BrIndentSpecial 2) line1) - (docLines $ lines ++ [end]) - ] - HsOpTy{} -> -- TODO - briDocByExactInlineOnly "HsOpTy{}" ltype - -- HsOpTy typ1 opName typ2 -> do - -- -- TODO: these need some proper fixing. precedences don't add up. - -- -- maybe the parser just returns some trivial right recursion - -- -- parse result for any type level operators. - -- -- need to check how things are handled on the expression level. - -- let opStr = lrdrNameToText opName - -- let opLen = Text.length opStr - -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 - -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 - -- let line = do -- Maybe - -- l1 <- _ldesc_line desc1 - -- l2 <- _ldesc_line desc2 - -- let len1 = _lColumns_min l1 - -- let len2 = _lColumns_min l2 - -- let len = 2 + opLen + len1 + len2 - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol1 <- descToBlockStart desc1 - -- (min2, max2) <- descToMinMax (1+opLen) desc2 - -- let (minR, maxR) = case descToBlockMinMax desc1 of - -- Nothing -> (min2, max2) - -- Just (min1, max1) -> (max min1 min2, max max1 max2) - -- return $ BlockDesc - -- { _bdesc_blockStart = rol1 - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Just (1+opLen) - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \params -> do - -- remaining <- getCurRemaining - -- let allowSameLine = _params_sepLines params /= SepLineTypeOp - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do - -- applyLayouterRestore layouter1 defaultParams - -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " - -- applyLayouterRestore layouter2 defaultParams - -- _ -> do - -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params - -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 - -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams - -- layoutWriteNewline - -- layoutWriteAppend $ opStr <> Text.pack " " - -- layoutWriteEnsureBlockPlusN downIndent - -- applyLayouterRestore layouter2 defaultParams - -- { _params_sepLines = SepLineTypeOp - -- , _params_opIndent = Just downIndent - -- } - -- , _layouter_ast = ltype - -- } - HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype - $ docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") - , docForceSingleline typeDoc1 - ] - , docPar - ( docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) - ) - (docCols ColTyOpPrefix - [ docWrapNodeRest ltype - $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ]) - ] - -- TODO: test KindSig - HsKindSig _ typ1 kind1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - kindDoc1 <- docSharedWrapper layoutType kind1 - hasParens <- hasAnnKeyword ltype AnnOpenP - docAlt - [ if hasParens - then docSeq - [ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - , docLit $ Text.pack ")" - ] - else docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - ] - , if hasParens - then docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 3) $ typeDoc1 - ] - , docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - , (docLit $ Text.pack ")") - ] - else docPar - typeDoc1 - ( docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - ) - ] - HsBangTy{} -> -- TODO - briDocByExactInlineOnly "HsBangTy{}" ltype - -- HsBangTy bang typ1 -> do - -- let bangStr = case bang of - -- HsSrcBang _ unpackness strictness -> - -- (++) - -- (case unpackness of - -- SrcUnpack -> "{-# UNPACK -#} " - -- SrcNoUnpack -> "{-# NOUNPACK -#} " - -- NoSrcUnpack -> "" - -- ) - -- (case strictness of - -- SrcLazy -> "~" - -- SrcStrict -> "!" - -- NoSrcStrict -> "" - -- ) - -- let bangLen = length bangStr - -- layouter@(Layouter desc _ _) <- layoutType typ1 - -- let line = do -- Maybe - -- l <- _ldesc_line desc - -- let len = bangLen + _lColumns_min l - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol <- descToBlockStart desc - -- (minR,maxR) <- descToBlockMinMax desc - -- return $ BlockDesc - -- { _bdesc_blockStart = rol - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Nothing - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \_params -> do - -- remaining <- getCurRemaining - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- applyLayouterRestore layouter defaultParams - -- _ -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- layoutWritePostCommentsRestore ltype - -- applyLayouterRestore layouter defaultParams - -- , _layouter_ast = ltype - -- } - HsSpliceTy{} -> -- TODO - briDocByExactInlineOnly "HsSpliceTy{}" ltype - HsDocTy{} -> -- TODO - briDocByExactInlineOnly "HsDocTy{}" ltype - HsRecTy{} -> -- TODO - briDocByExactInlineOnly "HsRecTy{}" ltype - HsExplicitListTy _ _ typs -> do - typDocs <- docSharedWrapper layoutType `mapM` typs - hasComments <- hasAnyCommentsBelow ltype - let specialCommaSep = appSep $ docLit $ Text.pack " ," - docAlt - [ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) - ++ [docLit $ Text.pack "]"] - , case splitFirstLast typDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "'[" - , docSeparator - , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e - ] - , docLit $ Text.pack " ]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) - ++ [docLit $ Text.pack " ]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> - docCols ColList [specialCommaSep, d] - lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] - HsExplicitTupleTy{} -> -- TODO - briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype - HsTyLit _ lit -> case lit of - HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsNumTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsStrTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> - docLit $ Text.pack "_" - HsSumTy{} -> -- TODO - briDocByExactInlineOnly "HsSumTy{}" ltype - HsStarTy _ isUnicode -> do - if isUnicode - then docLit $ Text.pack "\x2605" -- Unicode star - else docLit $ Text.pack "*" - XHsType{} -> error "brittany internal error: XHsType" - HsAppKindTy _ ty kind -> do - t <- docSharedWrapper layoutType ty - k <- docSharedWrapper layoutType kind - docAlt - [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar - t - (docSeq [docLit $ Text.pack "@", k ]) - ] - -layoutTyVarBndrs - :: [LHsTyVarBndr () GhcPs] - -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] -layoutTyVarBndrs = mapM $ \case - (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar _ _ lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - --- there is no specific reason this returns a list instead of a single --- BriDoc node. -processTyVarBndrsSingleline - :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] -processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case - (tname, Nothing) -> [docSeparator, docLit tname] - (tname, Just doc) -> - [ docSeparator - , docLit $ Text.pack "(" <> tname <> Text.pack " :: " - , docForceSingleline $ doc - , docLit $ Text.pack ")" - ] - -getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] -getBinders x = case x of - HsForAllVis _ b -> b - HsForAllInvis _ b -> fmap withoutSpecificity b - XHsForAllTelescope _ -> [] - -withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass -withoutSpecificity = fmap $ \case - UserTyVar a _ c -> UserTyVar a () c - KindedTyVar a _ c d -> KindedTyVar a () c d - XTyVarBndr a -> XTyVarBndr a diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Obfuscation where - -import Data.Char -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import System.Random - - - -obfuscate :: Text -> IO Text -obfuscate input = do - let predi x = isAlphaNum x || x `elem` "_'" - let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) - let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x - let filtered = filter exceptionFilter idents - mappings <- fmap Map.fromList $ filtered `forM` \x -> do - r <- createAlias x - pure (x, r) - let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings) - pure $ Text.concat $ fmap Text.pack groups' - -keywords :: [String] -keywords = - [ "case" - , "class" - , "data" - , "default" - , "deriving" - , "do" - , "mdo" - , "else" - , "forall" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "qualified" - , "then" - , "type" - , "where" - , "_" - , "foreign" - , "ccall" - , "as" - , "safe" - , "unsafe" - , "hiding" - , "proc" - , "rec" - , "family" - ] - -extraKWs :: [String] -extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] - -createAlias :: String -> IO String -createAlias xs = go NoHint xs - where - go _hint "" = pure "" - go hint (c : cr) = do - c' <- case hint of - VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] - VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c - cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr - pure (c' : cr') - -data Hint = NoHint | VocalHint | NoVocalHint - -_randomRange :: Random a => a -> a -> IO a -_randomRange lo hi = do - gen <- getStdGen - let (x, gen') = randomR (lo, hi) gen - setStdGen gen' - pure x - -randomFrom :: [a] -> IO a -randomFrom l = do - let hi = length l - 1 - gen <- getStdGen - let (x, gen') = randomR (0, hi) gen - setStdGen gen' - pure $ l List.!! x diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# OPTIONS_GHC -Wno-implicit-prelude #-} - -module Language.Haskell.Brittany.Internal.ParseModule where - -import qualified Control.Monad as Monad -import qualified Control.Monad.IO.Class as IO -import qualified Control.Monad.Trans.Except as Except -import qualified Data.Set as Set -import qualified GHC -import qualified GHC.ByteOrder -import qualified GHC.Data.Bag -import qualified GHC.Data.EnumSet -import qualified GHC.Data.StringBuffer -import qualified GHC.Driver.Session -import qualified GHC.Parser.Header -import qualified GHC.Platform -import qualified GHC.Settings -import qualified GHC.Types.Basic -import qualified GHC.Types.SrcLoc -import qualified GHC.Unit.Module.Name -import qualified GHC.Unit.State -import qualified GHC.Unit.Types -import qualified GHC.Utils.Error -import qualified GHC.Utils.Fingerprint -import qualified GHC.Utils.Misc -import qualified GHC.Utils.Ppr.Colour -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint - --- | Parses a Haskell module. Although this nominally requires IO, it is --- morally pure. It should have no observable effects. -parseModule - :: IO.MonadIO io - => [String] - -> FilePath - -> (GHC.Driver.Session.DynFlags -> io (Either String a)) - -> String - -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do - let - dynFlags1 = GHC.Driver.Session.gopt_set - -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both - -- of those modes have trouble parsing safe imports (@import safe ...@). - -- Neither passing in @"-XUnsafe"@ as a command line argument nor having - -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. - initialDynFlags - { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe - } - GHC.Driver.Session.Opt_KeepRawTokenStream - (dynFlags2, leftovers1, _) <- - GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 - $ fmap GHC.Types.SrcLoc.noLoc arguments1 - handleLeftovers leftovers1 - let - stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string - arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath - (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma - dynFlags2 - arguments2 - handleLeftovers leftovers2 - dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 - let - parseResult = - ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string - case parseResult of - Left errorMessages -> handleErrorMessages errorMessages - Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) - -handleLeftovers - :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () -handleLeftovers leftovers = - Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show - (fmap GHC.Types.SrcLoc.unLoc leftovers) - -handleErrorMessages - :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a -handleErrorMessages = - Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList - -initialCfgWeights :: GHC.Driver.Session.CfgWeights -initialCfgWeights = GHC.Driver.Session.CFGWeights - { GHC.Driver.Session.backEdgeBonus = 0 - , GHC.Driver.Session.callWeight = 0 - , GHC.Driver.Session.condBranchWeight = 0 - , GHC.Driver.Session.infoTablePenalty = 0 - , GHC.Driver.Session.likelyCondWeight = 0 - , GHC.Driver.Session.switchWeight = 0 - , GHC.Driver.Session.uncondWeight = 0 - , GHC.Driver.Session.unlikelyCondWeight = 0 - } - -initialDynFlags :: GHC.Driver.Session.DynFlags -initialDynFlags = GHC.Driver.Session.DynFlags - { GHC.Driver.Session.avx = False - , GHC.Driver.Session.avx2 = False - , GHC.Driver.Session.avx512cd = False - , GHC.Driver.Session.avx512er = False - , GHC.Driver.Session.avx512f = False - , GHC.Driver.Session.avx512pf = False - , GHC.Driver.Session.binBlobThreshold = 0 - , GHC.Driver.Session.bmiVersion = Nothing - , GHC.Driver.Session.cachedPlugins = [] - , GHC.Driver.Session.canGenerateDynamicToo = error "canGenerateDynamicToo" - , GHC.Driver.Session.canUseColor = False - , GHC.Driver.Session.cfgWeightInfo = initialCfgWeights - , GHC.Driver.Session.cmdlineFrameworks = [] - , GHC.Driver.Session.cmmProcAlignment = Nothing - , GHC.Driver.Session.colScheme = GHC.Utils.Ppr.Colour.defaultScheme - , GHC.Driver.Session.debugLevel = 0 - , GHC.Driver.Session.depExcludeMods = [] - , GHC.Driver.Session.depIncludeCppDeps = False - , GHC.Driver.Session.depIncludePkgDeps = False - , GHC.Driver.Session.depMakefile = "" - , GHC.Driver.Session.depSuffixes = [] - , GHC.Driver.Session.dirsToClean = error "dirsToClean" - , GHC.Driver.Session.dump_action = \_ _ _ _ _ _ -> pure () - , GHC.Driver.Session.dumpDir = Nothing - , GHC.Driver.Session.dumpFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.dumpPrefix = Nothing - , GHC.Driver.Session.dumpPrefixForce = Nothing - , GHC.Driver.Session.dylibInstallName = Nothing - , GHC.Driver.Session.dynHiSuf = "" - , GHC.Driver.Session.dynLibLoader = GHC.Driver.Session.Deployable - , GHC.Driver.Session.dynObjectSuf = "" - , GHC.Driver.Session.dynOutputFile = Nothing - , GHC.Driver.Session.enableTimeStats = False - , GHC.Driver.Session.extensionFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.extensions = [] - , GHC.Driver.Session.fatalWarningFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.fileSettings = initialFileSettings - , GHC.Driver.Session.filesToClean = error "filesToClean" - , GHC.Driver.Session.floatLamArgs = Nothing - , GHC.Driver.Session.flushErr = GHC.Driver.Session.defaultFlushErr - , GHC.Driver.Session.flushOut = GHC.Driver.Session.defaultFlushOut - , GHC.Driver.Session.frameworkPaths = [] - , GHC.Driver.Session.frontendPluginOpts = [] - , GHC.Driver.Session.generalFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.generatedDumps = error "generatedDumps" - , GHC.Driver.Session.ghcHeapSize = Nothing - , GHC.Driver.Session.ghciHistSize = 0 - , GHC.Driver.Session.ghciScripts = [] - , GHC.Driver.Session.ghcLink = GHC.Driver.Session.NoLink - , GHC.Driver.Session.ghcMode = GHC.Driver.Session.OneShot - , GHC.Driver.Session.ghcNameVersion = initialGhcNameVersion - , GHC.Driver.Session.ghcVersionFile = Nothing - , GHC.Driver.Session.haddockOptions = Nothing - , GHC.Driver.Session.hcSuf = "" - , GHC.Driver.Session.hiDir = Nothing - , GHC.Driver.Session.hieDir = Nothing - , GHC.Driver.Session.hieSuf = "" - , GHC.Driver.Session.historySize = 0 - , GHC.Driver.Session.hiSuf = "" - , GHC.Driver.Session.homeUnitId = GHC.Unit.Types.stringToUnitId "" - , GHC.Driver.Session.homeUnitInstanceOfId = Nothing - , GHC.Driver.Session.homeUnitInstantiations = [] - , GHC.Driver.Session.hooks = error "hooks" - , GHC.Driver.Session.hpcDir = "" - , GHC.Driver.Session.hscTarget = GHC.Driver.Session.HscNothing - , GHC.Driver.Session.ignorePackageFlags = [] - , GHC.Driver.Session.importPaths = [] - , GHC.Driver.Session.includePaths = initialIncludeSpecs - , GHC.Driver.Session.incoherentOnLoc = initialSrcSpan - , GHC.Driver.Session.initialUnique = 0 - , GHC.Driver.Session.inlineCheck = Nothing - , GHC.Driver.Session.interactivePrint = Nothing - , GHC.Driver.Session.language = Nothing - , GHC.Driver.Session.ldInputs = [] - , GHC.Driver.Session.liberateCaseThreshold = Nothing - , GHC.Driver.Session.libraryPaths = [] - , GHC.Driver.Session.liftLamsKnown = False - , GHC.Driver.Session.liftLamsNonRecArgs = Nothing - , GHC.Driver.Session.liftLamsRecArgs = Nothing - , GHC.Driver.Session.llvmConfig = initialLlvmConfig - , GHC.Driver.Session.log_action = \_ _ _ _ _ -> pure () - , GHC.Driver.Session.mainFunIs = Nothing - , GHC.Driver.Session.mainModIs = GHC.Unit.Types.mkModule - (GHC.Unit.Types.stringToUnit "") - (GHC.Unit.Module.Name.mkModuleName "") - , GHC.Driver.Session.maxErrors = Nothing - , GHC.Driver.Session.maxInlineAllocSize = 0 - , GHC.Driver.Session.maxInlineMemcpyInsns = 0 - , GHC.Driver.Session.maxInlineMemsetInsns = 0 - , GHC.Driver.Session.maxPmCheckModels = 0 - , GHC.Driver.Session.maxRefHoleFits = Nothing - , GHC.Driver.Session.maxRelevantBinds = Nothing - , GHC.Driver.Session.maxSimplIterations = 0 - , GHC.Driver.Session.maxUncoveredPatterns = 0 - , GHC.Driver.Session.maxValidHoleFits = Nothing - , GHC.Driver.Session.maxWorkerArgs = 0 - , GHC.Driver.Session.newDerivOnLoc = initialSrcSpan - , GHC.Driver.Session.nextTempSuffix = error "nextTempSuffix" - , GHC.Driver.Session.nextWrapperNum = error "nextWrapperNum" - , GHC.Driver.Session.objectDir = Nothing - , GHC.Driver.Session.objectSuf = "" - , GHC.Driver.Session.optLevel = 0 - , GHC.Driver.Session.outputFile = Nothing - , GHC.Driver.Session.outputHi = Nothing - , GHC.Driver.Session.overlapInstLoc = initialSrcSpan - , GHC.Driver.Session.packageDBFlags = [] - , GHC.Driver.Session.packageEnv = Nothing - , GHC.Driver.Session.packageFlags = [] - , GHC.Driver.Session.parMakeCount = Nothing - , GHC.Driver.Session.pkgTrustOnLoc = initialSrcSpan - , GHC.Driver.Session.platformConstants = initialPlatformConstants - , GHC.Driver.Session.platformMisc = initialPlatformMisc - , GHC.Driver.Session.pluginModNameOpts = [] - , GHC.Driver.Session.pluginModNames = [] - , GHC.Driver.Session.pluginPackageFlags = [] - , GHC.Driver.Session.pprCols = 80 - , GHC.Driver.Session.pprUserLength = 0 - , GHC.Driver.Session.profAuto = GHC.Driver.Session.NoProfAuto - , GHC.Driver.Session.rawSettings = [] - , GHC.Driver.Session.reductionDepth = GHC.Types.Basic.mkIntWithInf 0 - , GHC.Driver.Session.refLevelHoleFits = Nothing - , GHC.Driver.Session.reverseErrors = False - , GHC.Driver.Session.rtccInfo = error "rtccInfo" - , GHC.Driver.Session.rtldInfo = error "rtldInfo" - , GHC.Driver.Session.rtsOpts = Nothing - , GHC.Driver.Session.rtsOptsEnabled = GHC.Driver.Session.RtsOptsNone - , GHC.Driver.Session.rtsOptsSuggestions = False - , GHC.Driver.Session.ruleCheck = Nothing - , GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Ignore - , GHC.Driver.Session.safeInfer = False - , GHC.Driver.Session.safeInferred = False - , GHC.Driver.Session.simplPhases = 0 - , GHC.Driver.Session.simplTickFactor = 0 - , GHC.Driver.Session.solverIterations = GHC.Types.Basic.mkIntWithInf 0 - , GHC.Driver.Session.specConstrCount = Nothing - , GHC.Driver.Session.specConstrRecursive = 0 - , GHC.Driver.Session.specConstrThreshold = Nothing - , GHC.Driver.Session.splitInfo = Nothing - , GHC.Driver.Session.sseVersion = Nothing - , GHC.Driver.Session.staticPlugins = [] - , GHC.Driver.Session.strictnessBefore = [] - , GHC.Driver.Session.stubDir = Nothing - , GHC.Driver.Session.targetPlatform = initialTargetPlatform - , GHC.Driver.Session.thOnLoc = initialSrcSpan - , GHC.Driver.Session.toolSettings = initialToolSettings - , GHC.Driver.Session.trace_action = \_ _ _ a -> a - , GHC.Driver.Session.trustFlags = [] - , GHC.Driver.Session.trustworthyOnLoc = initialSrcSpan - , GHC.Driver.Session.ufCreationThreshold = 0 - , GHC.Driver.Session.ufDearOp = 0 - , GHC.Driver.Session.ufDictDiscount = 0 - , GHC.Driver.Session.ufFunAppDiscount = 0 - , GHC.Driver.Session.ufUseThreshold = 0 - , GHC.Driver.Session.ufVeryAggressive = False - , GHC.Driver.Session.uniqueIncrement = 0 - , GHC.Driver.Session.unitDatabases = Nothing - , GHC.Driver.Session.unitState = GHC.Unit.State.emptyUnitState - , GHC.Driver.Session.useColor = GHC.Utils.Misc.Never - , GHC.Driver.Session.useUnicode = False - , GHC.Driver.Session.verbosity = 0 - , GHC.Driver.Session.warningFlags = GHC.Data.EnumSet.fromList [] - , GHC.Driver.Session.warnSafeOnLoc = initialSrcSpan - , GHC.Driver.Session.warnUnsafeOnLoc = initialSrcSpan - , GHC.Driver.Session.ways = Set.empty - } - -initialFileSettings :: GHC.Driver.Session.FileSettings -initialFileSettings = GHC.Driver.Session.FileSettings - { GHC.Driver.Session.fileSettings_ghciUsagePath = "" - , GHC.Driver.Session.fileSettings_ghcUsagePath = "" - , GHC.Driver.Session.fileSettings_globalPackageDatabase = "" - , GHC.Driver.Session.fileSettings_tmpDir = "" - , GHC.Driver.Session.fileSettings_toolDir = Nothing - , GHC.Driver.Session.fileSettings_topDir = "" - } - -initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion -initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion - { GHC.Driver.Session.ghcNameVersion_programName = "" - , GHC.Driver.Session.ghcNameVersion_projectVersion = "" - } - -initialIncludeSpecs :: GHC.Driver.Session.IncludeSpecs -initialIncludeSpecs = GHC.Driver.Session.IncludeSpecs - { GHC.Driver.Session.includePathsGlobal = [] - , GHC.Driver.Session.includePathsQuote = [] - } - -initialLlvmConfig :: GHC.Driver.Session.LlvmConfig -initialLlvmConfig = GHC.Driver.Session.LlvmConfig - { GHC.Driver.Session.llvmPasses = [] - , GHC.Driver.Session.llvmTargets = [] - } - -initialPlatformConstants :: GHC.Settings.PlatformConstants -initialPlatformConstants = GHC.Settings.PlatformConstants - { GHC.Settings.pc_AP_STACK_SPLIM = 0 - , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0 - , GHC.Settings.pc_BLOCK_SIZE = 0 - , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0 - , GHC.Settings.pc_CINT_SIZE = 0 - , GHC.Settings.pc_CLONG_LONG_SIZE = 0 - , GHC.Settings.pc_CLONG_SIZE = 0 - , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0 - , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False - , GHC.Settings.pc_ILDV_CREATE_MASK = 0 - , GHC.Settings.pc_ILDV_STATE_CREATE = 0 - , GHC.Settings.pc_ILDV_STATE_USE = 0 - , GHC.Settings.pc_LDV_SHIFT = 0 - , GHC.Settings.pc_MAX_CHARLIKE = 0 - , GHC.Settings.pc_MAX_Double_REG = 0 - , GHC.Settings.pc_MAX_Float_REG = 0 - , GHC.Settings.pc_MAX_INTLIKE = 0 - , GHC.Settings.pc_MAX_Long_REG = 0 - , GHC.Settings.pc_MAX_Real_Double_REG = 0 - , GHC.Settings.pc_MAX_Real_Float_REG = 0 - , GHC.Settings.pc_MAX_Real_Long_REG = 0 - , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0 - , GHC.Settings.pc_MAX_Real_XMM_REG = 0 - , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0 - , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0 - , GHC.Settings.pc_MAX_Vanilla_REG = 0 - , GHC.Settings.pc_MAX_XMM_REG = 0 - , GHC.Settings.pc_MIN_CHARLIKE = 0 - , GHC.Settings.pc_MIN_INTLIKE = 0 - , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0 - , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0 - , GHC.Settings.pc_OFFSET_bdescr_blocks = 0 - , GHC.Settings.pc_OFFSET_bdescr_flags = 0 - , GHC.Settings.pc_OFFSET_bdescr_free = 0 - , GHC.Settings.pc_OFFSET_bdescr_start = 0 - , GHC.Settings.pc_OFFSET_Capability_r = 0 - , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0 - , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0 - , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0 - , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0 - , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 - , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0 - , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0 - , GHC.Settings.pc_OFFSET_stgGCFun = 0 - , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0 - , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0 - , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0 - , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0 - , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 - , GHC.Settings.pc_OFFSET_StgStack_sp = 0 - , GHC.Settings.pc_OFFSET_StgStack_stack = 0 - , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0 - , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0 - , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0 - , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0 - , GHC.Settings.pc_PROF_HDR_SIZE = 0 - , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0 - , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0 - , GHC.Settings.pc_REP_StgEntCounter_allocd = 0 - , GHC.Settings.pc_REP_StgEntCounter_allocs = 0 - , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0 - , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0 - , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0 - , GHC.Settings.pc_RESERVED_STACK_WORDS = 0 - , GHC.Settings.pc_SIZEOF_CostCentreStack = 0 - , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0 - , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0 - , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 - , GHC.Settings.pc_STD_HDR_SIZE = 0 - , GHC.Settings.pc_TAG_BITS = 0 - , GHC.Settings.pc_TICKY_BIN_COUNT = 0 - , GHC.Settings.pc_WORD_SIZE = 0 - } - -initialPlatformMini :: GHC.Settings.PlatformMini -initialPlatformMini = GHC.Settings.PlatformMini - { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 - , GHC.Settings.platformMini_os = GHC.Platform.OSLinux - } - -initialPlatformMisc :: GHC.Driver.Session.PlatformMisc -initialPlatformMisc = GHC.Driver.Session.PlatformMisc - { GHC.Driver.Session.platformMisc_ghcDebugged = False - , GHC.Driver.Session.platformMisc_ghcRTSWays = "" - , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False - , GHC.Driver.Session.platformMisc_ghcThreaded = False - , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False - , GHC.Driver.Session.platformMisc_ghcWithSMP = False - , GHC.Driver.Session.platformMisc_libFFI = False - , GHC.Driver.Session.platformMisc_llvmTarget = "" - , GHC.Driver.Session.platformMisc_targetPlatformString = "" - } - -initialSrcSpan :: GHC.Types.SrcLoc.SrcSpan -initialSrcSpan = - GHC.Types.SrcLoc.UnhelpfulSpan GHC.Types.SrcLoc.UnhelpfulNoLocationInfo - -initialTargetPlatform :: GHC.Settings.Platform -initialTargetPlatform = GHC.Settings.Platform - { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian - , GHC.Settings.platformHasGnuNonexecStack = False - , GHC.Settings.platformHasIdentDirective = False - , GHC.Settings.platformHasSubsectionsViaSymbols = False - , GHC.Settings.platformIsCrossCompiling = False - , GHC.Settings.platformLeadingUnderscore = False - , GHC.Settings.platformMini = initialPlatformMini - , GHC.Settings.platformTablesNextToCode = False - , GHC.Settings.platformUnregisterised = False - , GHC.Settings.platformWordSize = GHC.Platform.PW8 - } - -initialToolSettings :: GHC.Settings.ToolSettings -initialToolSettings = GHC.Settings.ToolSettings - { GHC.Settings.toolSettings_ccSupportsNoPie = False - , GHC.Settings.toolSettings_extraGccViaCFlags = [] - , GHC.Settings.toolSettings_ldIsGnuLd = False - , GHC.Settings.toolSettings_ldSupportsBuildId = False - , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False - , GHC.Settings.toolSettings_ldSupportsFilelist = False - , GHC.Settings.toolSettings_opt_a = [] - , GHC.Settings.toolSettings_opt_c = [] - , GHC.Settings.toolSettings_opt_cxx = [] - , GHC.Settings.toolSettings_opt_F = [] - , GHC.Settings.toolSettings_opt_i = [] - , GHC.Settings.toolSettings_opt_l = [] - , GHC.Settings.toolSettings_opt_L = [] - , GHC.Settings.toolSettings_opt_lc = [] - , GHC.Settings.toolSettings_opt_lcc = [] - , GHC.Settings.toolSettings_opt_lm = [] - , GHC.Settings.toolSettings_opt_lo = [] - , GHC.Settings.toolSettings_opt_P = [] - , GHC.Settings.toolSettings_opt_P_fingerprint = - GHC.Utils.Fingerprint.fingerprint0 - , GHC.Settings.toolSettings_opt_windres = [] - , GHC.Settings.toolSettings_pgm_a = ("", []) - , GHC.Settings.toolSettings_pgm_ar = "" - , GHC.Settings.toolSettings_pgm_c = "" - , GHC.Settings.toolSettings_pgm_dll = ("", []) - , GHC.Settings.toolSettings_pgm_F = "" - , GHC.Settings.toolSettings_pgm_i = "" - , GHC.Settings.toolSettings_pgm_install_name_tool = "" - , GHC.Settings.toolSettings_pgm_l = ("", []) - , GHC.Settings.toolSettings_pgm_L = "" - , GHC.Settings.toolSettings_pgm_lc = ("", []) - , GHC.Settings.toolSettings_pgm_lcc = ("", []) - , GHC.Settings.toolSettings_pgm_libtool = "" - , GHC.Settings.toolSettings_pgm_lm = ("", []) - , GHC.Settings.toolSettings_pgm_lo = ("", []) - , GHC.Settings.toolSettings_pgm_otool = "" - , GHC.Settings.toolSettings_pgm_P = ("", []) - , GHC.Settings.toolSettings_pgm_ranlib = "" - , GHC.Settings.toolSettings_pgm_T = "" - , GHC.Settings.toolSettings_pgm_windres = "" - } diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ /dev/null @@ -1,194 +0,0 @@ -module Language.Haskell.Brittany.Internal.Prelude - ( module E - ) where - -import Control.Applicative as E (Alternative(..), Applicative(..)) -import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) -import Control.Concurrent as E (forkIO, forkOS, threadDelay) -import Control.Concurrent.Chan as E (Chan) -import Control.Concurrent.MVar as E - (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) -import Control.Exception as E (assert, bracket, evaluate) -import Control.Monad as E - ( (<$!>) - , (<=<) - , (=<<) - , (>=>) - , Functor(..) - , Monad(..) - , MonadPlus(..) - , filterM - , forM - , forM_ - , forever - , guard - , join - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , mapM - , mapM_ - , replicateM - , replicateM_ - , sequence - , sequence_ - , unless - , void - , when - ) -import Control.Monad.Extra as E - (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) -import Control.Monad.IO.Class as E (MonadIO(..)) -import Control.Monad.ST as E (ST) -import Control.Monad.Trans.Class as E (lift) -import Control.Monad.Trans.Maybe as E (MaybeT(..)) -import Control.Monad.Trans.MultiRWS as E - (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) -import Data.Bifunctor as E (bimap) -import Data.Bool as E (Bool(..)) -import Data.Char as E (Char, chr, ord) -import Data.Data as E (toConstr) -import Data.Either as E (Either(..), either) -import Data.Foldable as E (asum, fold, foldl', foldr') -import Data.Function as E ((&), fix) -import Data.Functor as E (($>)) -import Data.Functor.Identity as E (Identity(..)) -import Data.IORef as E (IORef) -import Data.Int as E (Int) -import Data.List as E - ( all - , break - , drop - , dropWhile - , elem - , filter - , find - , intercalate - , intersperse - , isPrefixOf - , isSuffixOf - , iterate - , length - , mapAccumL - , mapAccumR - , maximum - , minimum - , notElem - , nub - , null - , partition - , repeat - , replicate - , sortBy - , sum - , take - , takeWhile - , transpose - , uncons - , unzip - , zip - , zip3 - , zipWith - ) -import Data.List.Extra as E (nubOrd, stripSuffix) -import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) -import Data.Map as E (Map) -import Data.Maybe as E - (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) -import Data.Monoid as E - ( All(..) - , Alt(..) - , Any(..) - , Endo(..) - , Monoid(..) - , Product(..) - , Sum(..) - , mconcat - ) -import Data.Ord as E (Down(..), Ordering(..), comparing) -import Data.Proxy as E (Proxy(..)) -import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) -import Data.Semigroup as E ((<>), Semigroup(..)) -import Data.Sequence as E (Seq) -import Data.Set as E (Set) -import Data.String as E (String) -import Data.Text as E (Text) -import Data.Tree as E (Tree(..)) -import Data.Tuple as E (swap) -import Data.Typeable as E (Typeable) -import Data.Version as E (showVersion) -import Data.Void as E (Void) -import Data.Word as E (Word, Word32) -import Debug.Trace as E - ( trace - , traceIO - , traceId - , traceM - , traceShow - , traceShowId - , traceShowM - , traceStack - ) -import Foreign.ForeignPtr as E (ForeignPtr) -import Foreign.Storable as E (Storable) -import GHC.Exts as E (Constraint) -import GHC.Hs.Extension as E (GhcPs) -import GHC.Types.Name.Reader as E (RdrName) -import Prelude as E - ( ($) - , ($!) - , (&&) - , (++) - , (.) - , (<$>) - , Bounded(..) - , Double - , Enum(..) - , Eq(..) - , Float - , Floating(..) - , Foldable - , Fractional(..) - , Integer - , Integral(..) - , Num(..) - , Ord(..) - , RealFloat(..) - , RealFrac(..) - , Show(..) - , Traversable - , (^) - , and - , any - , const - , curry - , error - , flip - , foldl - , foldr - , foldr1 - , fromIntegral - , fst - , head - , id - , map - , not - , or - , otherwise - , print - , putStr - , putStrLn - , realToFrac - , reverse - , seq - , snd - , subtract - , traverse - , uncurry - , undefined - , (||) - ) -import System.IO as E (IO, hFlush, stdout) -import Text.Read as E (readMaybe) diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Haskell.Brittany.Internal.PreludeUtils where - -import Control.Applicative -import Control.DeepSeq (NFData, force) -import Control.Exception.Base (evaluate) -import Control.Monad -import qualified Data.Strict.Maybe as Strict -import Debug.Trace -import Prelude -import System.IO - - - -instance Applicative Strict.Maybe where - pure = Strict.Just - Strict.Just f <*> Strict.Just x = Strict.Just (f x) - _ <*> _ = Strict.Nothing - -instance Monad Strict.Maybe where - Strict.Nothing >>= _ = Strict.Nothing - Strict.Just x >>= f = f x - -instance Alternative Strict.Maybe where - empty = Strict.Nothing - x <|> Strict.Nothing = x - _ <|> x = x - -traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) -traceFunctionWith name s1 s2 f x = trace traceStr y - where - y = f x - traceStr = - name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y - -(<&!>) :: Monad m => m a -> (a -> b) -> m b -(<&!>) = flip (<$!>) - -putStrErrLn :: String -> IO () -putStrErrLn s = hPutStrLn stderr s - -putStrErr :: String -> IO () -putStrErr s = hPutStr stderr s - -printErr :: Show a => a -> IO () -printErr = putStrErrLn . show - -errorIf :: Bool -> a -> a -errorIf False = id -errorIf True = error "errorIf" - -errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id -errorIfNote (Just x) = error x - -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = flip fmap -infixl 4 <&> - -(.>) :: (a -> b) -> (b -> c) -> (a -> c) -f .> g = g . f -infixl 9 .> - -evaluateDeep :: NFData a => a -> IO a -evaluateDeep = evaluate . force diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ /dev/null @@ -1,907 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Language.Haskell.Brittany.Internal.Transformations.Alt where - -import qualified Control.Monad.Memo as Memo -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.HList.ContainsType -import qualified Data.List.Extra -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -data AltCurPos = AltCurPos - { _acp_line :: Int -- chars in the current line - , _acp_indent :: Int -- current indentation level - , _acp_indentPrep :: Int -- indentChange affecting the next Par - , _acp_forceMLFlag :: AltLineModeState - } - deriving (Show) - -data AltLineModeState - = AltLineModeStateNone - | AltLineModeStateForceML Bool -- true ~ decays on next wrap - | AltLineModeStateForceSL - | AltLineModeStateContradiction - -- i.e. ForceX False -> ForceX True -> None - deriving (Show) - -altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction - -altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone -altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction - -mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos -mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of - (AltLineModeStateContradiction, _) -> acp - (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } - (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp - (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> - acp { _acp_forceMLFlag = s } - _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } - - --- removes any BDAlt's from the BriDoc -transformAlts - :: forall r w s - . ( Data.HList.ContainsType.ContainsType Config r - , Data.HList.ContainsType.ContainsType (Seq String) w - ) - => BriDocNumbered - -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts = - MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) - . Memo.startEvalMemoT - . fmap unwrapBriDocNumbered - . rec - where - -- this function is exponential by nature and cannot be improved in any - -- way i can think of, and i've tried. (stupid StableNames.) - -- transWrap :: BriDoc -> BriDocNumbered - -- transWrap brDc = flip StateS.evalState (1::Int) - -- $ Memo.startEvalMemoT - -- $ go brDc - -- where - -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i - -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered - -- go = Memo.memo $ \bdX -> do - -- i <- lift $ incGet - -- fmap (\bd' -> (i,bd')) $ case bdX of - -- BDEmpty -> return $ BDFEmpty - -- BDLit t -> return $ BDFLit t - -- BDSeq list -> BDFSeq <$> go `mapM` list - -- BDCols sig list -> BDFCols sig <$> go `mapM` list - -- BDSeparator -> return $ BDFSeparator - -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd - -- BDSetBaseY bd -> BDFSetBaseY <$> go bd - -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd - -- BDPar ind line indented -> [ BDFPar ind line' indented' - -- | line' <- go line - -- , indented' <- go indented - -- ] - -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen - -- BDForceMultiline bd -> BDFForceMultiline <$> go bd - -- BDForceSingleline bd -> BDFForceSingleline <$> go bd - -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd - -- BDExternal k ks c t -> return $ BDFExternal k ks c t - -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd - -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd - -- BDLines lines -> BDFLines <$> go `mapM` lines - -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd - -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd - - - - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered - rec bdX@(brDcId, brDc) = do - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> - reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> - reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp - { _acp_indent = ind - , _acp_indentPrep = 0 - } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' - { _acp_line = ind - , _acp_indent = ind - } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( hasSpace1 lconf acp vs && lineCheck vs, bd)) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ]) - $ zip [1..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let lineCheck (VerticalSpacing _ p _) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( any (hasSpace2 lconf acp) vs - && any lineCheck vs, bd)) - let checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do - mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l:lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp - { _acp_line = ind - , _acp_indent = ind - } - rec x - return $ reWrap $ BDFLines (l':lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do - acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - -getSpacing - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => BriDocNumbered - -> m (LineModeValidity VerticalSpacing) -getSpacing !bridoc = rec bridoc - where - rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) - rec (brDcId, brDc) = do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - result <- case brDc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> - return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False - BDFSeq list -> - sumVs <$> rec `mapM` list - BDFCols _sig list -> sumVs <$> rec `mapM` list - BDFSeparator -> - return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = VerticalSpacingParSome 0 - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVs <- rec sameLine - mIndSp <- rec indented - return - $ [ VerticalSpacing lsp pspResult parFlagResult - | VerticalSpacing lsp mPsp _ <- mVs - , indSp <- mIndSp - , lineMax <- getMaxVS $ mIndSp - , let pspResult = case mPsp of - VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax - , let parFlagResult = mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ] - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> do - mVs <- rec bd - return $ mVs >>= _vs_paragraph .> \case - VerticalSpacingParNone -> LineModeInvalid - _ -> mVs - BDFForceSingleline bd -> do - mVs <- rec bd - return $ mVs >>= _vs_paragraph .> \case - VerticalSpacingParNone -> mVs - _ -> LineModeInvalid - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False - BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return - $ LineModeValid - $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_:_) -> do - lSps <- rec `mapM` ls - let (mVs:_) = lSps -- separated into let to avoid MonadFail - return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp pf) -> - VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing b bd -> do - mVs <- rec bd - return - $ mVs - <|> LineModeValid - (VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r - return r - return result - maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - maxVs = foldl' - (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing (max x1 y1) (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) False)) - (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - sumVs sps = foldl' (liftM2 go) initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y) - x3 - singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False - isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int - getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - -data SpecialCompare = Unequal | Smaller | Bigger - -getSpacings - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => Int - -> BriDocNumbered - -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] -getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where - -- when we do `take K . filter someCondition` on a list of spacings, we - -- need to first (also) limit the size of the input list, otherwise a - -- _large_ input with a similarly _large_ prefix not passing our filtering - -- process could lead to exponential runtime behaviour. - -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3*limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let specialCompare vs1 vs2 = - if ( (_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let allowHangingQuasiQuotes = - config - & _conf_layout - & _lconfig_allowHangingQuasiQuotes - & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit - $ [ (x,y) - | x<-mVss - , y<-indSps - ] - return $ mVsIndSp <&> - \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp) - ( mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> - return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1 ] -> VerticalSpacing - (Text.length t1) - VerticalSpacingParNone - False - (t1 : _) -> VerticalSpacing - (Text.length t1) - (VerticalSpacingParAlways 0) - True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_:_) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let worbled = fmap reverse - $ sequence - $ reverse - $ lSpss - sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - sumF [] = error $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then [VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) - return r - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) - False) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i - -fixIndentationForMultiple - :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int -fixIndentationForMultiple acp indent = do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - -- for IndentPolicyMultiple, we restrict the amount of added - -- indentation in such a manner that we end up on a multiple of the - -- base indentation. - indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - pure $ if indPolicy == IndentPolicyMultiple - then - let indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 - else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Transformations.Columns where - -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types - - - -transformSimplifyColumns :: BriDoc -> BriDoc -transformSimplifyColumns = Uniplate.rewrite $ \case - -- BDWrapAnnKey annKey bd -> - -- BDWrapAnnKey annKey $ transformSimplify bd - BDEmpty -> Nothing - BDLit{} -> Nothing - BDSeq list | any (\case BDSeq{} -> True - BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) - | all (\case BDSeparator -> True; _ -> False) rest -> - Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) - BDLines lines | any (\case BDLines{} -> True - BDEmpty{} -> True - _ -> False) lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case - BDLines l -> l - x -> [x] - -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - -- post floating in - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - -- ensureIndent float-in - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- matching col special transformation - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 - , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 - , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> - Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) - | sig1==sig2 -> - Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) - BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) - -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) - -- | sig1==sig2 -> - -- Just $ BDPar - -- ind1 - -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 (List.init cols ++ [line]) - , BDCols sig2 cols2 - ] - BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] - , BDCols sig2 cols2 - ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing - BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing - BDForceSingleline{} -> Nothing - BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing - BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing - BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing - BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Transformations.Floating where - -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - --- note that this is not total, and cannot be with that exact signature. -mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" - - -transformSimplifyFloating :: BriDoc -> BriDoc -transformSimplifyFloating = stepBO .> stepFull - -- note that semantically, stepFull is completely sufficient. - -- but the bottom-up switch-to-top-down-on-match transformation has much - -- better complexity. - -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence - -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> - Just x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> - Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> - Just $ x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Transformations.Indent where - -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types - - - --- prepare layouting by translating BDPar's, replacing them with Indents and --- floating those in. This gives a more clear picture of what exactly is --- affected by what amount of indentation. -transformSimplifyIndent :: BriDoc -> BriDoc -transformSimplifyIndent = Uniplate.rewrite $ \case - BDPar ind (BDLines lines) indented -> - Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented] - BDPar ind (BDCols sig cols) indented -> - Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented]) - BDPar BrIndentNone _ _ -> Nothing - BDPar ind x indented -> - Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented) - -- BDPar ind x indented -> - -- Just $ BDLines - -- [ BDAddBaseY ind x - -- , BDEnsureIndent ind indented - -- ] - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case - BDLines l -> l - x -> [x] - BDLines [l] -> Just l - BDAddBaseY i (BDAnnotationPrior k x) -> - Just $ BDAnnotationPrior k (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationKW k kw x) -> - Just $ BDAnnotationKW k kw (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationRest k x) -> - Just $ BDAnnotationRest k (BDAddBaseY i x) - BDAddBaseY i (BDSeq l) -> - Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] - BDAddBaseY i (BDCols sig l) -> - Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] - BDAddBaseY _ lit@BDLit{} -> Just lit - - _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Transformations.Par where - -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -transformSimplifyPar :: BriDoc -> BriDoc -transformSimplifyPar = transformUp $ \case - -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2] - -- BDPar line indented -> - -- Just $ BDLines [line, indented] - -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 -> - -- Just $ BDPar ind1 line (BDLines [p1, p2]) - x@(BDPar _ (BDPar _ BDPar{} _) _) -> x - BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> - BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) - BDPar ind1 (BDPar ind2 line p1) p2 -> - BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs - where - go = (=<<) $ \case - BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x - -- BDCols sig cols | BDPar ind line indented <- List.last cols -> - -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented - -- BDPar BrIndentNone line indented -> - -- Just $ BDLines [line, indented] - BDEnsureIndent BrIndentNone x -> x - x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Language.Haskell.Brittany.Internal.Types where - -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Data.Data -import Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Kind as Kind -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint (AnnKey) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types (Anns) -import qualified Safe - - -data PerItemConfig = PerItemConfig - { _icd_perBinding :: Map String (CConfig Maybe) - , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) - } - deriving Data.Data.Data - -type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] - '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] - -type PPMLocal = MultiRWSS.MultiRWS - '[Config, ExactPrint.Anns] - '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] - -newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) - -data LayoutState = LayoutState - { _lstate_baseYs :: [Int] - -- ^ stack of number of current indentation columns - -- (not number of indentations). - , _lstate_curYOrAddNewline :: Either Int Int - -- ^ Either: - -- 1) number of chars in the current line. - -- 2) number of newlines to be inserted before inserting any - -- non-space elements. - , _lstate_indLevels :: [Int] - -- ^ stack of current indentation levels. set for - -- any layout-affected elements such as - -- let/do/case/where elements. - -- The main purpose of this member is to - -- properly align comments, as their - -- annotation positions are relative to the - -- current layout indentation level. - , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for - -- properly treating cases where comments - -- on the first indented element have an - -- annotation offset relative to the last - -- non-indented element, which is confusing. - , _lstate_comments :: Anns - , _lstate_commentCol :: Maybe Int -- this communicates two things: - -- firstly, that cursor is currently - -- at the end of a comment (so needs - -- newline before any actual content). - -- secondly, the column at which - -- insertion of comments started. - , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone - -- writes (any non-spaces) in the - -- current line. - -- , _lstate_isNewline :: NewLineState - -- -- captures if the layouter currently is in a new line, i.e. if the - -- -- current line only contains (indentation) spaces. - -- this is mostly superseeded by curYOrAddNewline, iirc. - , _lstate_commentNewlines :: Int -- number of newlines inserted due to - -- move-to-DP at a start of a comment. - -- Necessary because some keyword DPs - -- are relative to the last non-comment - -- entity (for some reason). - -- This is not very strictly reset to 0, - -- so we might in some cases get "artifacts" - -- from previous document elements. - -- But the worst effect at the moment would - -- be that we introduce less newlines on - -- moveToKWDP, which seems harmless enough. - } - -lstate_baseY :: LayoutState -> Int -lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs - -lstate_indLevel :: LayoutState -> Int -lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels - --- evil, incomplete Show instance; only for debugging. -instance Show LayoutState where - show state = - "LayoutState" - ++ "{baseYs=" ++ show (_lstate_baseYs state) - ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) - ++ ",indLevels=" ++ show (_lstate_indLevels state) - ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) - ++ ",commentCol=" ++ show (_lstate_commentCol state) - ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) - ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) - ++ "}" - --- data NewLineState = NewLineStateInit -- initial state. we do not know if in a --- -- newline, really. by special-casing --- -- this we can appropriately handle it --- -- differently at use-site. --- | NewLineStateYes --- | NewLineStateNo --- deriving Eq - --- data LayoutSettings = LayoutSettings --- { _lsettings_cols :: Int -- the thing that has default 80. --- , _lsettings_indentPolicy :: IndentPolicy --- , _lsettings_indentAmount :: Int --- , _lsettings_indentWhereSpecial :: Bool -- indent where only 1 sometimes (TODO). --- , _lsettings_indentListSpecial :: Bool -- use some special indentation for "," --- -- when creating zero-indentation --- -- multi-line list literals. --- , _lsettings_importColumn :: Int --- , _lsettings_initialAnns :: ExactPrint.Anns --- } - -data BrittanyError - = ErrorInput String - -- ^ parsing failed - | ErrorUnusedComment String - -- ^ internal error: some comment went missing - | ErrorMacroConfig String String - -- ^ in-source config string parsing error; first argument is the parser - -- output and second the corresponding, ill-formed input. - | LayoutWarning String - -- ^ some warning - | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) - -- ^ internal error: pretty-printing is not implemented for type of node - -- in the syntax-tree - | ErrorOutputCheck - -- ^ checking the output for syntactic validity failed - -data BriSpacing = BriSpacing - { _bs_spacePastLineIndent :: Int -- space in the current, - -- potentially somewhat filled - -- line. - , _bs_spacePastIndent :: Int -- space required in properly - -- indented blocks below the - -- current line. - } - -data ColSig - = ColTyOpPrefix - -- any prefixed operator/paren/"::"/.. - -- expected to have exactly two colums. - -- e.g. ":: foo" - -- 111222 - -- "-> bar asd asd" - -- 11122222222222 - | ColPatternsFuncPrefix - -- pattern-part of the lhs, e.g. "func (foo a b) c _". - -- Has variable number of columns depending on the number of patterns. - | ColPatternsFuncInfix - -- pattern-part of the lhs, e.g. "Foo a <> Foo b". - -- Has variable number of columns depending on the number of patterns. - | ColPatterns - | ColCasePattern - | ColBindingLine (Maybe Text) - -- e.g. "func pat pat = expr" - -- 1111111111111222222 - -- or "pat | stmt -> expr" - -- 111111111112222222 - -- expected to have exactly two columns. - | ColGuard - -- e.g. "func pat pat | cond = ..." - -- 11111111111112222222 - -- or "pat | cond1, cond2 -> ..." - -- 1111222222222222222 - -- expected to have exactly two columns - | ColGuardedBody - -- e.g. | foofoo = 1 - -- | bar = 2 - -- 111111111222 - -- expected to have exactly two columns - | ColBindStmt - | ColDoLet -- the non-indented variant - | ColRec - | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? - | ColRecDecl - | ColListComp - | ColList - | ColApp Text - | ColTuple - | ColTuples - | ColOpPrefix -- merge with ColList ? other stuff? - | ColImport - - -- TODO - deriving (Eq, Ord, Data.Data.Data, Show) - -data BrIndent = BrIndentNone - | BrIndentRegular - | BrIndentSpecial Int - deriving (Eq, Ord, Data.Data.Data, Show) - -type ToBriDocM = MultiRWSS.MultiRWS - '[Config, Anns] -- reader - '[[BrittanyError], Seq String] -- writer - '[NodeAllocIndex] -- state - -type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c - -data DocMultiLine - = MultiLineNo - | MultiLinePossible - deriving (Eq) - --- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot --- of transformations on `BriDocF Identity`s and it is really annoying to --- `Identity`/`runIdentity` everywhere. -data BriDoc - = -- BDWrapAnnKey AnnKey BriDoc - BDEmpty - | BDLit !Text - | BDSeq [BriDoc] -- elements other than the last should - -- not contains BDPars. - | BDCols ColSig [BriDoc] -- elements other than the last - -- should not contains BDPars - | BDSeparator -- semantically, space-unless-at-end-of-line. - | BDAddBaseY BrIndent BriDoc - | BDBaseYPushCur BriDoc - | BDBaseYPop BriDoc - | BDIndentLevelPushCur BriDoc - | BDIndentLevelPop BriDoc - | BDPar - { _bdpar_indent :: BrIndent - , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars - , _bdpar_indented :: BriDoc - } - -- | BDAddIndent BrIndent (BriDocF f) - -- | BDNewline - | BDAlt [BriDoc] - | BDForwardLineMode BriDoc - | BDExternal AnnKey - (Set AnnKey) -- set of annkeys contained within the node - -- to be printed via exactprint - Bool -- should print extra comment ? - Text - | BDPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) - | BDAnnotationPrior AnnKey BriDoc - | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc - | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset - | BDLines [BriDoc] - | BDEnsureIndent BrIndent BriDoc - -- the following constructors are only relevant for the alt transformation - -- and are removed afterwards. They should never occur in any BriDoc - -- after the alt transformation. - | BDForceMultiline BriDoc - | BDForceSingleline BriDoc - | BDNonBottomSpacing Bool BriDoc - | BDSetParSpacing BriDoc - | BDForceParSpacing BriDoc - -- pseudo-deprecated - | BDDebug String BriDoc - deriving (Data.Data.Data, Eq, Ord) - -data BriDocF f - = -- BDWrapAnnKey AnnKey BriDoc - BDFEmpty - | BDFLit !Text - | BDFSeq [f (BriDocF f)] -- elements other than the last should - -- not contains BDPars. - | BDFCols ColSig [f (BriDocF f)] -- elements other than the last - -- should not contains BDPars - | BDFSeparator -- semantically, space-unless-at-end-of-line. - | BDFAddBaseY BrIndent (f (BriDocF f)) - | BDFBaseYPushCur (f (BriDocF f)) - | BDFBaseYPop (f (BriDocF f)) - | BDFIndentLevelPushCur (f (BriDocF f)) - | BDFIndentLevelPop (f (BriDocF f)) - | BDFPar - { _bdfpar_indent :: BrIndent - , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars - , _bdfpar_indented :: f (BriDocF f) - } - -- | BDAddIndent BrIndent (BriDocF f) - -- | BDNewline - | BDFAlt [f (BriDocF f)] - | BDFForwardLineMode (f (BriDocF f)) - | BDFExternal AnnKey - (Set AnnKey) -- set of annkeys contained within the node - -- to be printed via exactprint - Bool -- should print extra comment ? - Text - | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) - | BDFAnnotationPrior AnnKey (f (BriDocF f)) - | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) - | BDFAnnotationRest AnnKey (f (BriDocF f)) - | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset - | BDFLines [(f (BriDocF f))] - | BDFEnsureIndent BrIndent (f (BriDocF f)) - | BDFForceMultiline (f (BriDocF f)) - | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing Bool (f (BriDocF f)) - | BDFSetParSpacing (f (BriDocF f)) - | BDFForceParSpacing (f (BriDocF f)) - | BDFDebug String (f (BriDocF f)) - --- deriving instance Data.Data.Data (BriDocF Identity) -deriving instance Data.Data.Data (BriDocF ((,) Int)) - -type BriDocFInt = BriDocF ((,) Int) -type BriDocNumbered = (Int, BriDocFInt) - -instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list ) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts ) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - uniplate (BDAnnotationPrior annKey bd) = - plate BDAnnotationPrior |- annKey |* bd - uniplate (BDAnnotationKW annKey kw bd) = - plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = - plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw b bd) = - plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines ) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd - -newtype NodeAllocIndex = NodeAllocIndex Int - --- TODO: rename to "dropLabels" ? -unwrapBriDocNumbered :: BriDocNumbered -> BriDoc -unwrapBriDocNumbered tpl = case snd tpl of - BDFEmpty -> BDEmpty - BDFLit t -> BDLit t - BDFSeq list -> BDSeq $ rec <$> list - BDFCols sig list -> BDCols sig $ rec <$> list - BDFSeparator -> BDSeparator - BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDFBaseYPop bd -> BDBaseYPop $ rec bd - BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDFPar ind line indented -> BDPar ind (rec line) (rec indented) - BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDFForwardLineMode bd -> BDForwardLineMode $ rec bd - BDFExternal k ks c t -> BDExternal k ks c t - BDFPlain t -> BDPlain t - BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd - BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd - BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd - BDFLines lines -> BDLines $ rec <$> lines - BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where rec = unwrapBriDocNumbered - -isNotEmpty :: BriDoc -> Bool -isNotEmpty BDEmpty = False -isNotEmpty _ = True - --- this might not work. is not used anywhere either. -briDocSeqSpine :: BriDoc -> () -briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd - BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDPlain{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd - -briDocForceSpine :: BriDoc -> BriDoc -briDocForceSpine bd = briDocSeqSpine bd `seq` bd - - -data VerticalSpacingPar - = VerticalSpacingParNone -- no indented lines - | VerticalSpacingParSome Int -- indented lines, requiring this much - -- vertical space at most - | VerticalSpacingParAlways Int -- indented lines, requiring this much - -- vertical space at most, but should - -- be considered as having space for - -- any spacing validity check. - -- TODO: it might be wrong not to extend "always" to the none case, i.e. - -- we might get better properties of spacing operators by having a - -- product like (Normal|Always, None|Some Int). - deriving (Eq, Show) - -data VerticalSpacing - = VerticalSpacing - { _vs_sameLine :: !Int - , _vs_paragraph :: !VerticalSpacingPar - , _vs_parFlag :: !Bool - } - deriving (Eq, Show) - -newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) - deriving (Functor, Applicative, Monad, Show, Alternative) - -pattern LineModeValid :: forall t. t -> LineModeValidity t -pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t -pattern LineModeInvalid :: forall t. LineModeValidity t -pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.Utils where - -import qualified Data.ByteString as B -import qualified Data.Coerce -import Data.Data -import Data.Generics.Aliases -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import DataTreePrint -import qualified GHC.Data.FastString as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Hs.Extension as HsExtension -import qualified GHC.OldList as List -import GHC.Types.Name.Occurrence as OccName (occNameString) -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Utils.Outputable as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils -import qualified Text.PrettyPrint as PP - - - -parDoc :: String -> PP.Doc -parDoc = PP.fsep . fmap PP.text . List.words - -parDocW :: [String] -> PP.Doc -parDocW = PP.fsep . fmap PP.text . List.words . List.unwords - - -showSDoc_ :: GHC.SDoc -> String -showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags - -showOutputable :: (GHC.Outputable a) => a -> String -showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags - -fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y - -fromOptionIdentity :: Identity a -> Maybe a -> Identity a -fromOptionIdentity x y = - Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y - --- maximum monoid over N+0 --- or more than N, because Num is allowed. -newtype Max a = Max { getMax :: a } - deriving (Eq, Ord, Show, Bounded, Num) - -instance (Num a, Ord a) => Semigroup (Max a) where - (<>) = Data.Coerce.coerce (max :: a -> a -> a) - -instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 - mappend = (<>) - -newtype ShowIsId = ShowIsId String deriving Data - -instance Show ShowIsId where show (ShowIsId x) = x - -data A x = A ShowIsId x deriving Data - -customLayouterF :: ExactPrint.Types.Anns -> LayouterF -customLayouterF anns layoutF = - DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan - `ext2Q` located - where - DataToLayouter f = defaultLayouterF layoutF - simpleLayouter :: String -> NodeLayouter - simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) - showIsId :: ShowIsId -> NodeLayouter - showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s - fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString - -> NodeLayouter - bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString - srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter - -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" ++ showOutputable ss ++ "}" - located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter - located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a - where - annStr = case cast ss of - Just (s :: GHC.SrcSpan) -> - ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) - Nothing -> ShowIsId "nnnnnnnn" - -customLayouterNoAnnsF :: LayouterF -customLayouterNoAnnsF layoutF = - DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan - `ext2Q` located - where - DataToLayouter f = defaultLayouterF layoutF - simpleLayouter :: String -> NodeLayouter - simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) - showIsId :: ShowIsId -> NodeLayouter - showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s - fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString - -> NodeLayouter - bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString - srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" - located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter - located (GHC.L _ss a) = runDataToLayouter layoutF a - --- displayBriDocTree :: BriDoc -> PP.Doc --- displayBriDocTree = \case --- BDWrapAnnKey annKey doc -> def "BDWrapAnnKey" --- $ PP.text (show annKey) --- $+$ displayBriDocTree doc --- BDEmpty -> PP.text "BDEmpty" --- BDLit t -> def "BDLit" $ PP.text (show t) --- BDSeq list -> def "BDSeq" $ displayList list --- BDCols sig list -> def "BDCols" $ PP.text (show sig) --- $+$ displayList list --- BDSeparator -> PP.text "BDSeparator" --- BDPar rol indent lines -> def "BDPar" $ displayBriDocTree rol --- $+$ PP.text (show indent) --- $+$ displayList lines --- BDAlt alts -> def "BDAlt" $ displayList alts --- BDExternal ast _t -> def "BDExternal" (astToDoc ast) --- BDSpecialPostCommentLoc _ -> PP.text "BDSpecialPostCommentLoc" --- where --- def x r = PP.text x $+$ PP.nest 2 r --- displayList :: [BriDoc] -> PP.Doc --- displayList [] = PP.text "[]" --- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocTree x --- : [PP.text "," <+> displayBriDocTree t | t<-xr] --- ++ [PP.text "]"] - --- displayBriDocSimpleTree :: BriDocSimple -> PP.Doc --- displayBriDocSimpleTree = \case --- BDSWrapAnnKey annKey doc -> def "BDSWrapAnnKey" --- $ PP.text (show annKey) --- $+$ displayBriDocSimpleTree doc --- BDSLit t -> def "BDSLit" $ PP.text (show t) --- BDSSeq list -> def "BDSSeq" $ displayList list --- BDSCols sig list -> def "BDSCols" $ PP.text (show sig) --- $+$ displayList list --- BDSSeparator -> PP.text "BDSSeparator" --- BDSPar rol indent lines -> def "BDSPar" $ displayBriDocSimpleTree rol --- $+$ PP.text (show indent) --- $+$ displayList lines --- BDSExternal annKey _subKeys _t -> def "BDSExternal" (PP.text $ show annKey) --- BDSSpecialPostCommentLoc _ -> PP.text "BDSSpecialPostCommentLoc" --- where --- def x r = PP.text x $+$ PP.nest 2 r --- displayList :: [BriDocSimple] -> PP.Doc --- displayList [] = PP.text "[]" --- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocSimpleTree x --- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr] --- ++ [PP.text "]"] - -traceIfDumpConf - :: (MonadMultiReader Config m, Show a) - => String - -> (DebugConfig -> Identity (Semigroup.Last Bool)) - -> a - -> m () -traceIfDumpConf s accessor val = do - whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do - trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () - -tellDebugMess :: MonadMultiWriter - (Seq String) m => String -> m () -tellDebugMess s = mTell $ Seq.singleton s - -tellDebugMessShow :: forall a m . (MonadMultiWriter - (Seq String) m, Show a) => a -> m () -tellDebugMessShow = tellDebugMess . show - --- i should really put that into multistate.. -mModify :: MonadMultiState s m => (s -> s) -> m () -mModify f = mGet >>= mSet . f - -astToDoc :: Data ast => ast -> PP.Doc -astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast - -briDocToDoc :: BriDoc -> PP.Doc -briDocToDoc = astToDoc . removeAnnotations - where - removeAnnotations = Uniplate.transform $ \case - BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x - -briDocToDocWithAnns :: BriDoc -> PP.Doc -briDocToDocWithAnns = astToDoc - -annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) - -breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1:aR) = case fn a1 of - Left b -> (b : bs, cs) - Right c -> (bs, c : cs) - where - (bs, cs) = breakEither fn aR - -spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) - where - (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) - -data FirstLastView a - = FirstLastEmpty - | FirstLastSingleton a - | FirstLast a [a] a - -splitFirstLast :: [a] -> FirstLastView a -splitFirstLast [] = FirstLastEmpty -splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) - --- TODO: move to uniplate upstream? --- aka `transform` -transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -transformUp f = g where g = f . Uniplate.descend g -_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -_transformDown f = g where g = Uniplate.descend g . f -transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x -_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x - --- | similar to List.lines, but treating the case of final newline character --- in such a manner that this function is the inverse of @intercalate "\n"@. -lines' :: String -> [String] -lines' s = case break (== '\n') s of - (s1, []) -> [s1] - (s1, [_]) -> [s1, ""] - (s1, (_:r)) -> s1 : lines' r - -absurdExt :: HsExtension.NoExtCon -> a -absurdExt = HsExtension.noExtCon diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs deleted file mode 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ /dev/null @@ -1,483 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Main where - -import Control.Monad (zipWithM) -import qualified Control.Monad.Trans.Except as ExceptT -import Data.CZipWith -import qualified Data.Either -import qualified Data.List.Extra -import qualified Data.Monoid -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import DataTreePrint -import GHC (GenLocated(L)) -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC -import qualified GHC.OldList as List -import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Obfuscation -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Paths_brittany -import qualified System.Directory as Directory -import qualified System.Environment as Environment -import qualified System.Exit -import qualified System.FilePath.Posix as FilePath -import qualified System.IO -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Text.PrettyPrint as PP -import Text.Read (Read(..)) -import UI.Butcher.Monadic - - - -data WriteMode = Display | Inplace - -instance Read WriteMode where - readPrec = val "display" Display <|> val "inplace" Inplace - where val iden v = ReadPrec.lift $ ReadP.string iden >> return v - -instance Show WriteMode where - show Display = "display" - show Inplace = "inplace" - - -main :: IO () -main = do - progName <- Environment.getProgName - args <- Environment.getArgs - mainWith progName args - -mainWith :: String -> [String] -> IO () -mainWith progName args = - Environment.withProgName progName - . Environment.withArgs args - $ mainFromCmdParserWithHelpDesc mainCmdParser - -helpDoc :: PP.Doc -helpDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDocW - [ "Reformats one or more haskell modules." - , "Currently affects only the module head (imports/exports), type" - , "signatures and function bindings;" - , "everything else is left unmodified." - , "Based on ghc-exactprint, thus (theoretically) supporting all" - , "that ghc does." - ] - , parDoc $ "Example invocations:" - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany" - , PP.nest 2 $ PP.text "read from stdin, output to stdout" - ] - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" - , PP.nest 2 $ PP.vcat - [ PP.text "run on all modules in current directory (no backup!)" - , PP.text "4 spaces indentation" - ] - ] - , parDocW - [ "This program is written carefully and contains safeguards to ensure" - , "the output is syntactically valid and that no comments are removed." - , "Nonetheless, this is a young project, and there will always be bugs," - , "and ensuring that the transformation never changes semantics of the" - , "transformed source is currently not possible." - , "Please do check the output and do not let brittany override your large" - , "codebase without having backups." - ] - , parDoc $ "There is NO WARRANTY, to the extent permitted by law." - , parDocW - [ "This program is free software released under the AGPLv3." - , "For details use the --license flag." - ] - , parDoc $ "See https://github.com/lspitzner/brittany" - , parDoc - $ "Please report bugs at" - ++ " https://github.com/lspitzner/brittany/issues" - ] - -licenseDoc :: PP.Doc -licenseDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" - , parDoc $ "Copyright (C) 2019 PRODA LTD" - , parDocW - [ "This program is free software: you can redistribute it and/or modify" - , "it under the terms of the GNU Affero General Public License," - , "version 3, as published by the Free Software Foundation." - ] - , parDocW - [ "This program is distributed in the hope that it will be useful," - , "but WITHOUT ANY WARRANTY; without even the implied warranty of" - , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , "GNU Affero General Public License for more details." - ] - , parDocW - [ "You should have received a copy of the GNU Affero General Public" - , "License along with this program. If not, see" - , "." - ] - ] - - -mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () -mainCmdParser helpDesc = do - addCmdSynopsis "haskell source pretty printer" - addCmdHelp $ helpDoc - -- addCmd "debugArgs" $ do - addHelpCommand helpDesc - addCmd "license" $ addCmdImpl $ print $ licenseDoc - -- addButcherDebugCommand - reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser - suppressOutput <- addSimpleBoolFlag - "" - ["suppress-output"] - (flagHelp $ parDoc - "suppress the regular output, i.e. the transformed haskell source" - ) - _verbosity <- addSimpleCountFlag - "v" - ["verbose"] - (flagHelp $ parDoc "[currently without effect; TODO]") - checkMode <- addSimpleBoolFlag - "c" - ["check-mode"] - (flagHelp - (PP.vcat - [ PP.text "check for changes but do not write them out" - , PP.text "exits with code 0 if no changes necessary, 1 otherwise" - , PP.text "and print file path(s) of files that have changes to stdout" - ] - ) - ) - writeMode <- addFlagReadParam - "" - ["write-mode"] - "(display|inplace)" - ( flagHelp - (PP.vcat - [ PP.text "display: output for any input(s) goes to stdout" - , PP.text "inplace: override respective input file (without backup!)" - ] - ) - Data.Monoid.<> flagDefault Display - ) - inputParams <- addParamNoFlagStrings - "PATH" - (paramHelpStr "paths to input/inout haskell source files") - reorderStop - addCmdImpl $ void $ do - when printLicense $ do - print licenseDoc - System.Exit.exitSuccess - when printVersion $ do - do - putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" - putStrLn $ "Copyright (C) 2019 PRODA LTD" - putStrLn $ "There is NO WARRANTY, to the extent permitted by law." - System.Exit.exitSuccess - when printHelp $ do - liftIO - $ putStrLn - $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } - $ ppHelpShallow helpDesc - System.Exit.exitSuccess - - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths - - configsToLoad <- liftIO $ if null configPaths - then - maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths - - config <- - runMaybeT - (if noUserConfig - then readConfigs cmdlineConfig configsToLoad - else readConfigsWithUserConfig cmdlineConfig configsToLoad - ) - >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x - when (config & _conf_debug & _dconf_dump_config & confUnpack) - $ trace (showConfigYaml config) - $ return () - - results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths - - if checkMode - then when (Changes `elem` (Data.Either.rights results)) - $ System.Exit.exitWith (System.Exit.ExitFailure 1) - else case results of - xs | all Data.Either.isRight xs -> pure () - [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) - - -data ChangeStatus = Changes | NoChanges - deriving (Eq) - --- | The main IO parts for the default mode of operation, and after commandline --- and config stuff is processed. -coreIO - :: (String -> IO ()) -- ^ error output function. In parallel operation, you - -- may want serialize the different outputs and - -- consequently not directly print to stderr. - -> Config -- ^ global program config. - -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so - -- currently not part of program config. - -> Bool -- ^ whether we are (just) in check mode. - -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. - -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. - -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = - ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - -- there is a good of code duplication between the following code and the - -- `pureModuleTransform` function. Unfortunately, there are also a good - -- amount of slight differences: This module is a bit more verbose, and - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- the flag will do the following: insert a marker string - -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - -- The flag is intentionally misspelled to prevent clashing with - -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - (parseResult, originalContents) <- case inputPathM of - Nothing -> do - -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id - inputString <- liftIO System.IO.getContents - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) - return (parseRes, Text.pack inputString) - Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc - inputText <- Text.IO.readFile p - -- The above means we read the file twice, but the - -- GHC API does not really expose the source it - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> - -- handle still open -> write below crashes - evil.) - return (parseRes, inputText) - case parseResult of - Left left -> do - putErrorLn "parse error:" - putErrorLn left - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - of - Left (err, input) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - ExceptT.throwE 61 - Right c -> -- trace (showTree c) $ - pure c - let moduleConf = cZipWith fromOptionIdentity config inlineConf - when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - let disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack - (errsWarns, outSText, hasChanges) <- do - if - | disableFormatting -> do - pure ([], originalContents, False) - | exactprintOnly -> do - let r = Text.pack $ ExactPrint.exactPrint parsedSource anns - pure ([], r, r /= originalContents) - | otherwise -> do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return - $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - else outRaw - out' <- if moduleConf & _conf_obfuscate & confUnpack - then lift $ obfuscate out - else pure out - pure $ (ews, out', out' /= originalContents) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 - unless (null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{} : _) -> do - putErrorLn - $ "ERROR: brittany pretty printer" - ++ " returned syntactically invalid result." - (ErrorInput str : _) -> do - putErrorLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{} : _) -> do - putErrorLn - $ "WARNING: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) - when - ( config - & _conf_debug - & _dconf_dump_ast_unknown - & confUnpack - ) - $ do - putErrorLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - putErrorLn - " -> falling back on exactprint for this element of the module" - warns@(LayoutWarning{} : _) -> do - putErrorLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{} : _) -> do - putErrorLn - $ "Error: detected unprocessed comments." - ++ " The transformation output will most likely" - ++ " not contain some of the comments" - ++ " present in the input haskell source file." - putErrorLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" - (ErrorMacroConfig err input : _) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - [] -> error "cannot happen" - -- TODO: don't output anything when there are errors unless user - -- adds some override? - let - hasErrors = - if config & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) - outputOnErrs = - config - & _conf_errorHandling - & _econf_produceOutputOnErrors - & confUnpack - shouldOutput = - not suppressOutput - && not checkMode - && (not hasErrors || outputOnErrs) - - when shouldOutput - $ addTraceSep (_conf_debug config) - $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges - unless isIdentical $ Text.IO.writeFile p $ outSText - - when (checkMode && hasChanges) $ case inputPathM of - Nothing -> pure () - Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p - - when hasErrors $ ExceptT.throwE 70 - return (if hasChanges then Changes else NoChanges) - where - addTraceSep conf = - if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] - then trace "----" - else id diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs --- 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