diff --git a/brittany.yaml b/brittany.yaml deleted file mode 100644 index fba01fd..0000000 --- a/brittany.yaml +++ /dev/null @@ -1,5 +0,0 @@ -conf_layout: - lconfig_cols: 79 - lconfig_columnAlignMode: - tag: ColumnAlignModeDisabled - lconfig_indentPolicy: IndentPolicyLeft diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs index a2726c8..8c225c6 100644 --- a/source/library/Language/Haskell/Brittany.hs +++ b/source/library/Language/Haskell/Brittany.hs @@ -16,9 +16,13 @@ module Language.Haskell.Brittany , CForwardOptions(..) , CPreProcessorConfig(..) , BrittanyError(..) - ) where + ) +where -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types + + + +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index f2f0fdc..71e885b 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -12,52 +12,68 @@ module Language.Haskell.Brittany.Internal , parseModuleFromString , extractCommentConfigs , getTopLevelDeclNameMap - ) where + ) +where -import Control.Monad.Trans.Except + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Char (isSpace) -import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Data.Yaml -import qualified GHC hiding (parseModule) -import GHC (GenLocated(L)) -import GHC.Data.Bag -import qualified GHC.Driver.Session as GHC -import GHC.Hs -import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.SrcLoc (SrcSpan) -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Indent -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint + +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified UI.Butcher.Monadic as Butcher + +import Control.Monad.Trans.Except +import Data.HList.HList +import qualified Data.Yaml +import Data.CZipWith +import qualified UI.Butcher.Monadic as Butcher + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.LayouterBasics + +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Backend +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import Language.Haskell.Brittany.Internal.Transformations.Alt +import Language.Haskell.Brittany.Internal.Transformations.Floating +import Language.Haskell.Brittany.Internal.Transformations.Par +import Language.Haskell.Brittany.Internal.Transformations.Columns +import Language.Haskell.Brittany.Internal.Transformations.Indent + +import qualified GHC + hiding ( parseModule ) +import GHC.Parser.Annotation ( AnnKeywordId(..) ) +import GHC ( GenLocated(L) + ) +import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Hs +import GHC.Data.Bag +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Data.Char ( isSpace ) + + data InlineConfigTarget = InlineConfigTargetModule @@ -75,36 +91,35 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do [ ( k , [ x | (ExactPrint.Comment x _ _, _) <- - (ExactPrint.annPriorComments ann + ( ExactPrint.annPriorComments ann ++ ExactPrint.annFollowingComments ann ) ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] ) | (k, ann) <- Map.toList anns ] - let - configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - (("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) + let configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + ( ("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) let configParser = Butcher.addAlternatives [ ( "commandline-config" @@ -123,44 +138,39 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do ] parser = do -- we will (mis?)use butcher here to parse the inline config -- line. - let - nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + let nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let - nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + let nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding - let - disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let - disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let - disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) + let disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do @@ -168,42 +178,41 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) Butcher.addNullCmd $ do bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser + conf <- configParser Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) conf <- configParser Butcher.addCmdImpl (InlineConfigTargetModule, conf) lineConfigss <- configLiness `forM` \(k, ss) -> do r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c + Left err -> Left $ (err, s) + Right c -> Right $ c pure (k, r) - let - perModule = foldl' - (<>) - mempty - [ conf - | (_, lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf) <- lineConfigs - ] + let perModule = foldl' + (<>) + mempty + [ conf + | (_ , lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf ) <- lineConfigs + ] let perBinding = Map.fromListWith (<>) [ (n, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs - , n <- case target of + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , n <- case target of InlineConfigTargetBinding s -> [s] - InlineConfigTargetNextBinding - | Just name <- Map.lookup k declNameMap -> [name] + InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> + [name] _ -> [] ] let perKey = Map.fromListWith (<>) [ (k, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs , case target of InlineConfigTargetNextDecl -> True InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> @@ -221,7 +230,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls + | decl <- decls , (name : _) <- [getDeclBindingNames decl] ] @@ -239,78 +248,70 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = -- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configWithDebugs inputText = runExceptT $ do - let - config = - configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let config = + configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack (anns, parsedSource, hasCPP) <- do - let - hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let - hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False parseResult <- lift $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x + Left err -> throwE [ErrorInput err] + Right x -> pure x (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting then do return inputText else do (errsWarns, outputTextL) <- do - let - omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack + let omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConfig perItemConf anns parsedSource else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let - hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews - , TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw + , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn + (TextL.pack "\n") + outRaw ) else (ews, outRaw) - let - customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let - hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack then not $ null errsWarns else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors @@ -330,27 +331,26 @@ pPrintModule -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf inlineConf anns parsedModule = - let - ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) + let ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do -- -- debugStrings `forM_` \s -> @@ -365,17 +365,15 @@ pPrintModuleAndCheck -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString - ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let - errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] + parseResult <- parseModuleFromString ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] return (errs', output) @@ -386,22 +384,18 @@ parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of - Left err -> - return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) + Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) Right (anns, parsedModule) -> runExceptT $ do (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) - of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x + case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let - omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (errs, ltext) <- if omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift @@ -411,13 +405,13 @@ parsePrintModuleTests conf filename input = do else let errStrs = errs <&> \case - ErrorInput str -> str + ErrorInput str -> str ErrorUnusedComment str -> str - LayoutWarning str -> str + LayoutWarning str -> str ErrorUnknownNode str _ -> str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs isErrorUnusedComment :: BrittanyError -> Bool isErrorUnusedComment x = case x of @@ -470,30 +464,27 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do let annKey = ExactPrint.mkAnnKey lmod post <- ppPreamble lmod decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl + let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let - mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk <&> \annMap -> - Map.union (Map.findWithDefault Map.empty annKey annMap) - $ Map.findWithDefault Map.empty declAnnKey annMap + let mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk + <&> \annMap -> + Map.union (Map.findWithDefault Map.empty annKey annMap) $ + Map.findWithDefault Map.empty declAnnKey annMap - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns config <- mAsk - let - config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + let config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) - let - exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do bd <- if exactprintOnly then briDocMToPPM $ briDocByExactNoComment decl @@ -506,34 +497,33 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd - let - finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post + let finalComments = filter + (fst .> \case + ExactPrint.AnnComment{} -> True + _ -> False + ) + post post `forM_` \case (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let - folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> - ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] + _ -> [] -- Prints the information associated with the module annotation @@ -550,9 +540,8 @@ ppPreamble lmod@(L loc m@HsModule{}) = do -- attached annotations that come after the module's where -- from the module node config <- mAsk - let - shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + let shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack let (filteredAnns', post) = @@ -562,23 +551,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do let modAnnsDp = ExactPrint.annsDP mAnn isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False + isWhere _ = False isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp (pre, post') = case (whereInd, eofInd) of (Nothing, Nothing) -> ([], modAnnsDp) - (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) - (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in (filteredAnns'', post') - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations + in + (filteredAnns'', post') + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns' if shouldReformatPreamble @@ -587,7 +576,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule return post _sigHead :: Sig GhcPs -> String @@ -600,7 +589,7 @@ _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" @@ -618,67 +607,63 @@ layoutBriDoc briDoc = do transformAlts briDoc >>= mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt -- bridoc transformation: float stuff in mGet >>= transformSimplifyFloating .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf - "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating + .> traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating -- bridoc transformation: par removal mGet >>= transformSimplifyPar .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par -- bridoc transformation: float stuff in mGet >>= transformSimplifyColumns .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns -- bridoc transformation: indent mGet >>= transformSimplifyIndent .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl anns :: ExactPrint.Anns <- mAsk - let - state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } + let state = LayoutState { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - let - remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] + let remainingComments = + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs index 0dfa6d6..142fe2f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -6,6 +6,10 @@ module Language.Haskell.Brittany.Internal.Backend where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.State.Strict as StateS import qualified Data.Either as Either import qualified Data.Foldable as Foldable @@ -17,32 +21,32 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -type ColIndex = Int +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + + +import qualified Data.Text.Lazy.Builder as Text.Builder + + + +type ColIndex = Int data ColumnSpacing = ColumnSpacingLeaf Int | ColumnSpacingRef Int Int -type ColumnBlock a = [a] +type ColumnBlock a = [a] type ColumnBlocks a = Seq [a] -type ColMap1 - = IntMapL.IntMap {- ColIndex -} - (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 - = IntMapL.IntMap {- ColIndex -} - (Float, ColumnBlock Int, ColumnBlocks Int) +type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) -- (ratio of hasSpace, maximum, raw) data ColInfo @@ -52,23 +56,20 @@ data ColInfo instance Show ColInfo where show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = - "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = - "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") + show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list data ColBuildState = ColBuildState { _cbs_map :: ColMap1 , _cbs_index :: ColIndex } -type LayoutConstraints m - = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) +type LayoutConstraints m = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM = \case @@ -89,11 +90,10 @@ layoutBriDocM = \case BDSeparator -> do layoutAddSepSpace BDAddBaseY indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ layoutBriDocM bd BDBaseYPushCur bd -> do layoutBaseYPushCur @@ -108,39 +108,36 @@ layoutBriDocM = \case layoutBriDocM bd layoutIndentLevelPop BDEnsureIndent indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteEnsureBlock layoutBriDocM bd BDPar indent sameLine indented -> do layoutBriDocM sameLine - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteNewlineBlock layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt : _) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt:_) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd BDExternal annKey subKeys shouldAddComment t -> do - let - tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines + let tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines anns :: ExactPrint.Anns <- mAsk when shouldAddComment $ do layoutWriteAppend - $ Text.pack - $ "{-" + $ Text.pack + $ "{-" ++ show (annKey, Map.lookup annKey anns) ++ "-}" zip [1 ..] tlines `forM_` \(i, l) -> do @@ -157,10 +154,9 @@ layoutBriDocM = \case BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let - moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey + let moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -171,8 +167,8 @@ layoutBriDocM = \case } return mAnn case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace priors @@ -180,10 +176,9 @@ layoutBriDocM = \case when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y @@ -195,20 +190,18 @@ layoutBriDocM = \case layoutBriDocM bd mComments <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let - mToSpan = case mAnn of - Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> - Just annR - _ -> Nothing + let mToSpan = case mAnn of + Just anns | Maybe.isNothing keyword -> Just anns + Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just + annR + _ -> Nothing case mToSpan of Just anns -> do - let - (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing + let (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing mSet $ state { _lstate_comments = Map.adjust (\ann -> ann { ExactPrint.annsDP = rest }) @@ -220,19 +213,17 @@ layoutBriDocM = \case case mComments of Nothing -> pure () Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd @@ -241,26 +232,21 @@ layoutBriDocM = \case let m = _lstate_comments state pure $ Map.lookup annKey m let mComments = nonEmpty . extractAllComments =<< annMay - let - semiCount = length - [ () - | Just ann <- [annMay] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- - mAsk - <&> _conf_layout - .> _lconfig_experimentalSemicolonNewlines - .> confUnpack + let semiCount = length [ () + | Just ann <- [ annMay ] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- mAsk <&> + _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack mModify $ \state -> state { _lstate_comments = Map.adjust - (\ann -> ann - { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } + ( \ann -> ann { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = + flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } ) annKey (_lstate_comments state) @@ -268,40 +254,37 @@ layoutBriDocM = \case case mComments of Nothing -> do when shouldAddSemicolonNewlines $ do - [1 .. semiCount] `forM_` const layoutWriteNewline + [1..semiCount] `forM_` const layoutWriteNewline Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#' : _) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack comment + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) 1 + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let - relevant = - [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] + let relevant = [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] case relevant of [] -> pure Nothing - (ExactPrint.Types.DP (y, x) : _) -> do + (ExactPrint.Types.DP (y, x):_) -> do mSet state { _lstate_commentNewlines = 0 } pure $ Just (y - _lstate_commentNewlines state, x) case mDP of @@ -312,8 +295,8 @@ layoutBriDocM = \case layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" layoutBriDocM bd @@ -324,73 +307,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc -- appended at the current position. where rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc where rec :: BriDoc -> Bool rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_] -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= @@ -475,16 +458,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe 0 (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack case () of _ -> do -- tellDebugMess ("processedMap: " ++ show processedMap) sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos <&> processInfo colMax processedMap where (colInfos, finalState) = @@ -501,41 +484,40 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do where alignMax' = max 0 alignMax processedMap :: ColMap2 - processedMap = fix $ \result -> - _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + processedMap = + fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> let colss = colSpacingss <&> \spss -> case reverse spss of [] -> [] - (xN : xR) -> - reverse - $ (if lastFlag then fLast else fInit) xN - : fmap fInit xR + (xN:xR) -> + reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR where - fLast (ColumnSpacingLeaf len) = len + fLast (ColumnSpacingLeaf len ) = len fLast (ColumnSpacingRef len _) = len fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of - Nothing -> 0 + fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of + Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} fmap colAggregation $ transpose $ Foldable.toList colss (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols counter count l = if List.last posXs + List.last l <= colMax then count + 1 else count ratio = fromIntegral (foldl counter (0 :: Int) colss) / fromIntegral (length colss) - in (ratio, maxCols, colss) + in + (ratio, maxCols, colss) mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd : bdr) = do - info <- mergeInfoBriDoc True lastInfo bd + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd:bdr) = do + info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info) @@ -563,27 +545,28 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- personal preference to not break alignment for those, even if -- multiline. Really, this should be configurable.. (TODO) shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True + shouldBreakAfter bd = alignBreak && + briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp{} _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True mergeInfoBriDoc :: Bool @@ -591,22 +574,23 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -> BriDoc -> StateS.StateT ColBuildState Identity ColInfo mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs -> do + | infoSig == colSig && length subLengthsInfos == length subDocs + -> do let isLastList = if lastFlag - then (== length subDocs) <$> [1 ..] + then (==length subDocs) <$> [1 ..] else repeat False infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs + let curLengths = briDocLineLength <$> subDocs let trueSpacings = getTrueSpacings (zip curLengths infos) do -- update map s <- StateS.get - let m = _cbs_map s + let m = _cbs_map s let (Just (_, spaces)) = IntMapS.lookup infoInd m StateS.put s { _cbs_map = IntMapS.insert @@ -615,17 +599,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do m } return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise -> briDocToColInfo lastFlag brdc + | otherwise + -> briDocToColInfo lastFlag brdc brdc -> return $ ColInfoNo brdc briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo lastFlag = \case BDCols sig list -> withAlloc lastFlag $ \ind -> do - let - isLastList = - if lastFlag then (== length list) <$> [1 ..] else repeat False + let isLastList = + if lastFlag then (==length list) <$> [1 ..] else repeat False subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos + let lengthInfos = zip (briDocLineLength <$> list) subInfos let trueSpacings = getTrueSpacings lengthInfos return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) bd -> return $ ColInfoNo bd @@ -633,11 +617,11 @@ briDocToColInfo lastFlag = \case getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings lengthInfos = lengthInfos <&> \case (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _) -> ColumnSpacingLeaf len + (len, _ ) -> ColumnSpacingLeaf len withAlloc :: Bool - -> ( ColIndex + -> ( ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) ) -> StateS.State ColBuildState ColInfo @@ -652,14 +636,13 @@ withAlloc lastFlag f = do processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ do colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMode <- - mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do + alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack + curX <- do state <- mGet -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state @@ -671,11 +654,10 @@ processInfo maxSpace m = \case let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let - maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l + let maxCols2 = list <&> \case + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l let maxCols = zipWith max maxCols1 maxCols2 let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols -- handle the cases that the vertical alignment leads to more than max @@ -686,48 +668,46 @@ processInfo maxSpace m = \case -- sizes in such a way that it works _if_ we have sizes (*factor) -- in each column. but in that line, in the last column, we will be -- forced to occupy the full vertical space, not reduced by any factor. - let - fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (* factor) .> truncate - _ -> posXs - let - spacings = - zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs + let fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (*factor) .> truncate + _ -> posXs + let spacings = zipWith (-) + (List.tail fixedPosXs ++ [min maxX colMax]) + fixedPosXs -- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let - alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct + let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. + then noAlignAct + else alignAct case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct processInfoIgnore :: LayoutConstraints m => ColInfo -> m () processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index e48da84..6c34ea9 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -3,29 +3,42 @@ module Language.Haskell.Brittany.Internal.BackendUtils where + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Either import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (Located) import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -traceLocal :: (MonadMultiState LayoutState m) => a -> m () +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey + , Annotation + ) + +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.Brittany.Internal.Utils + +import GHC ( Located ) + + + +traceLocal + :: (MonadMultiState LayoutState m) + => a + -> m () traceLocal _ = return () layoutWriteAppend - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Text -> m () layoutWriteAppend t = do @@ -41,13 +54,15 @@ layoutWriteAppend t = do mTell $ Text.Builder.fromText $ t mModify $ \s -> s { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces , _lstate_addSepSpace = Nothing } layoutWriteAppendSpaces - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () layoutWriteAppendSpaces i = do @@ -55,18 +70,20 @@ layoutWriteAppendSpaces i = do unless (i == 0) $ do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state + { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state } layoutWriteAppendMultiline - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => [Text] -> m () layoutWriteAppendMultiline ts = do traceLocal ("layoutWriteAppendMultiline", ts) case ts of - [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. - (l : lr) -> do + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. + (l:lr) -> do layoutWriteAppend l lr `forM_` \x -> do layoutWriteNewline @@ -74,15 +91,16 @@ layoutWriteAppendMultiline ts = do -- adds a newline and adds spaces to reach the base column. layoutWriteNewlineBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteNewlineBlock = do traceLocal ("layoutWriteNewlineBlock") state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - } + mSet $ state { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + } -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- , MonadMultiWriter (Seq String) m) => Int -> m () @@ -98,13 +116,13 @@ layoutWriteNewlineBlock = do -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } -layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () +layoutSetCommentCol + :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol = do state <- mGet - let - col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + let col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state traceLocal ("layoutSetCommentCol", col) unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } @@ -112,7 +130,9 @@ layoutSetCommentCol = do -- This is also used to move to non-comments in a couple of places. Seems -- to be harmless so far.. layoutMoveToCommentPos - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> Int -> Int @@ -122,35 +142,38 @@ layoutMoveToCommentPos y x commentLines = do state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y + Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = + , _lstate_addSepSpace = Just $ if Data.Maybe.isJust (_lstate_commentCol state) then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_commentCol = + Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 + _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteNewline = do traceLocal ("layoutWriteNewline") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing + , _lstate_addSepSpace = Nothing } _layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () @@ -158,67 +181,77 @@ _layoutResetCommentNewlines = do mModify $ \state -> state { _lstate_commentNewlines = 0 } layoutWriteEnsureNewlineBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteEnsureNewlineBlock = do traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing } layoutWriteEnsureAbsoluteN - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let - diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c, _) -> n - c - (Nothing, Left i) -> n - i - (Nothing, Right{}) -> n + let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c , _ ) -> n - c + (Nothing, Left i ) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to + mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to -- at least (Just 1), so we won't -- overwrite any old value in any -- bad way. + } -layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m () +layoutBaseYPushInternal + :: (MonadMultiState LayoutState m) + => Int + -> m () layoutBaseYPushInternal i = do traceLocal ("layoutBaseYPushInternal", i) mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } -layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m () +layoutBaseYPopInternal + :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal = do traceLocal ("layoutBaseYPopInternal") mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m) => Int -> m () + :: (MonadMultiState LayoutState m) + => Int + -> m () layoutIndentLevelPushInternal i = do traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s - { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } -layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPopInternal + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal = do traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s - { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } -layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () +layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger = do - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + } layoutWithAddBaseCol :: ( MonadMultiWriter Text.Builder.Builder m @@ -250,7 +283,9 @@ layoutWithAddBaseColBlock m = do layoutBaseYPopInternal layoutWithAddBaseColNBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () -> m () @@ -263,23 +298,27 @@ layoutWithAddBaseColNBlock amount m = do layoutBaseYPopInternal layoutWriteEnsureBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => m () layoutWriteEnsureBlock = do traceLocal ("layoutWriteEnsureBlock") state <- mGet let diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i) -> lstate_baseY state - i + (Nothing, Left i ) -> lstate_baseY state - i (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i) -> max sp (lstate_baseY state - i) + (Just sp, Left i ) -> max sp (lstate_baseY state - i) (Just sp, Right{}) -> max sp (lstate_baseY state) -- when (diff>0) $ layoutWriteNewlineBlock when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just $ diff } layoutWithAddBaseColN - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) => Int -> m () -> m () @@ -289,36 +328,39 @@ layoutWithAddBaseColN amount m = do m layoutBaseYPopInternal -layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () +layoutBaseYPushCur + :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur = do traceLocal ("layoutBaseYPushCur") state <- mGet case _lstate_commentCol state of Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> layoutBaseYPushInternal (i + j) - (Left i, Nothing) -> layoutBaseYPushInternal i - (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state + (Left i , Just j ) -> layoutBaseYPushInternal (i + j) + (Left i , Nothing) -> layoutBaseYPushInternal i + (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state Just cCol -> layoutBaseYPushInternal cCol -layoutBaseYPop :: (MonadMultiState LayoutState m) => m () +layoutBaseYPop + :: (MonadMultiState LayoutState m) => m () layoutBaseYPop = do traceLocal ("layoutBaseYPop") layoutBaseYPopInternal -layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPushCur + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur = do traceLocal ("layoutIndentLevelPushCur") state <- mGet - let - y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> i + j - (Left i, Nothing) -> i - (Right{}, Just j) -> j - (Right{}, Nothing) -> 0 + let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i , Just j ) -> i + j + (Left i , Nothing) -> i + (Right{}, Just j ) -> j + (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y -layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPop + :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") layoutIndentLevelPopInternal @@ -328,12 +370,12 @@ layoutIndentLevelPop = do -- make sense. layoutRemoveIndentLevelLinger -layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () +layoutAddSepSpace :: (MonadMultiState LayoutState m) + => m () layoutAddSepSpace = do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state - } + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. @@ -348,7 +390,7 @@ moveToExactAnn annKey = do traceLocal ("moveToExactAnn", annKey) anns <- mAsk case Map.lookup annKey anns of - Nothing -> return () + Nothing -> return () Just ann -> do -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann @@ -357,19 +399,19 @@ moveToExactAnn annKey = do moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY y = mModify $ \state -> - let - upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in - state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just - (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } + let upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then + _lstate_commentCol state + <|> _lstate_addSepSpace state + <|> Just (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do @@ -379,7 +421,9 @@ moveToY y = mModify $ \state -> -- else x ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () + :: MonadMultiWriter Text.Builder.Builder m + => ExactPrint.DeltaPos + -> m () ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ y $ mTell $ Text.Builder.fromString " " @@ -395,77 +439,75 @@ layoutWritePriorComments layoutWritePriorComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - key - anns + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns } return mAnn case mAnn of Nothing -> return () Just priors -> do unless (null priors) $ layoutSetCommentCol - priors - `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment + priors `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. -- per documentation, this seems sufficient, as the -- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Located ast - -> m () +layoutWritePostComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Located ast -> m () layoutWritePostComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just posts -> do unless (null posts) $ layoutSetCommentCol - posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> - do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment + posts `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment - :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) + :: ( MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + ) => m () layoutIndentRestorePostComment = do state <- mGet let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state - mModify - $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } + let eCurYAddNL = _lstate_curYOrAddNewline state + mModify $ \s -> s { _lstate_commentCol = Nothing + , _lstate_commentNewlines = 0 + } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe - 0 - (_lstate_addSepSpace state) - _ -> return () + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) + _ -> return () -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs index b951db9..66d6d7f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -3,174 +3,185 @@ module Language.Haskell.Brittany.Internal.Config where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Bool as Bool import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Coerce (coerce) -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Semigroup as Semigroup -import qualified Data.Yaml import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances () -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Utils -import qualified System.Console.CmdArgs.Explicit as CmdArgs import qualified System.Directory -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath import qualified System.IO -import UI.Butcher.Monadic +import qualified Data.Yaml +import Data.CZipWith + +import UI.Butcher.Monadic + +import qualified System.Console.CmdArgs.Explicit + as CmdArgs + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config.Types.Instances () +import Language.Haskell.Brittany.Internal.Utils + +import Data.Coerce ( coerce + ) +import qualified Data.List.NonEmpty as NonEmpty + +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] } --- brittany-next-binding --columns 200 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") - dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") - dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") - dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") - dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") - dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") - dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = mempty } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Bool.bool Nothing (Just True) @@ -217,8 +228,8 @@ readConfig path = do fileConf <- case Data.Yaml.decodeEither' contents of Left e -> do liftIO - $ putStrErrLn - $ "error reading in brittany config from " + $ putStrErrLn + $ "error reading in brittany config from " ++ path ++ ":" liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) @@ -232,12 +243,11 @@ readConfig path = do userConfigPath :: IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith - Directory.doesFileExist - searchDirs - "config.yaml" + globalConfig <- Directory.findFileWith Directory.doesFileExist + searchDirs + "config.yaml" maybe (writeUserConfig userBritPathXdg) pure globalConfig where writeUserConfig dir = do @@ -249,7 +259,7 @@ userConfigPath = do -- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir + let dirParts = FilePath.splitDirectories dir -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" @@ -261,9 +271,8 @@ readConfigs -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let - merged = - Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + let merged = Semigroup.sconcat + $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 0b81ae6..929ac90 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -7,54 +7,63 @@ module Language.Haskell.Brittany.Internal.Config.Types where -import Data.CZipWith -import Data.Coerce (Coercible, coerce) -import Data.Data (Data) -import qualified Data.Semigroup as Semigroup -import Data.Semigroup (Last) -import Data.Semigroup.Generic -import GHC.Generics + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils () +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import Data.Data ( Data ) + +import Data.Coerce ( Coercible, coerce ) + +import Data.Semigroup.Generic +import Data.Semigroup ( Last ) + +import Data.CZipWith + + confUnpack :: Coercible a b => Identity a -> b confUnpack (Identity x) = coerce x data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. , _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentAmount :: f (Last Int) , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) + , _lconfig_importColumn :: f (Last Int) -- ^ for import statement layouting, column at which to align the -- elements to be imported from a module. -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) + , _lconfig_importAsColumn :: f (Last Int) -- ^ for import statement layouting, column at which put the module's -- "as" name (which also affects the positioning of the "as" keyword). -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) + , _lconfig_alignmentLimit :: f (Last Int) -- roughly speaking, this sets an upper bound to the number of spaces -- inserted to create horizontal alignment. -- More specifically, if 'xs' are the widths of the columns in some @@ -139,17 +148,17 @@ data CLayoutConfig f = LayoutConfig -- -- > , y :: Double -- -- > } } - deriving Generic + deriving (Generic) data CForwardOptions f = ForwardOptions { _options_ghc :: f [String] } - deriving Generic + deriving (Generic) data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) -- ^ Determines when to fall back on the exactprint'ed output when -- syntactical constructs are encountered which are not yet handled by -- brittany. @@ -159,21 +168,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig -- has different semantics than the code pre-transformation. , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CPreProcessorConfig f = PreProcessorConfig { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config @@ -184,9 +193,10 @@ data CConfig f = Config -- module. Useful for wildcard application -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) + , _conf_obfuscate :: f (Semigroup.Last Bool) + } - deriving Generic + deriving (Generic) type DebugConfig = CDebugConfig Identity type LayoutConfig = CLayoutConfig Identity diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index be7a0bb..2c0c78f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -18,16 +18,22 @@ module Language.Haskell.Brittany.Internal.Config.Types.Instances where + + +import Language.Haskell.Brittany.Internal.Prelude + +import Data.Yaml import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson -import Data.Yaml + import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude + + aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany = Aeson.defaultOptions { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (== '_') + , Aeson.fieldLabelModifier = dropWhile (=='_') } instance FromJSON (CDebugConfig Maybe) where @@ -102,18 +108,17 @@ instance ToJSON (CConfig Maybe) where -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- config file content. instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = - Config - <$> (v .:? Key.fromString "conf_version") - <*> (v .:?= Key.fromString "conf_debug") - <*> (v .:?= Key.fromString "conf_layout") - <*> (v .:?= Key.fromString "conf_errorHandling") - <*> (v .:?= Key.fromString "conf_forward") - <*> (v .:?= Key.fromString "conf_preprocessor") - <*> (v .:? Key.fromString "conf_roundtrip_exactprint_only") - <*> (v .:? Key.fromString "conf_disable_formatting") - <*> (v .:? Key.fromString "conf_obfuscate") - parseJSON invalid = Aeson.typeMismatch "Config" invalid + parseJSON (Object v) = Config + <$> v .:? Key.fromString "conf_version" + <*> v .:?= Key.fromString "conf_debug" + <*> v .:?= Key.fromString "conf_layout" + <*> v .:?= Key.fromString "conf_errorHandling" + <*> v .:?= Key.fromString "conf_forward" + <*> v .:?= Key.fromString "conf_preprocessor" + <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" + <*> v .:? Key.fromString "conf_disable_formatting" + <*> v .:? Key.fromString "conf_obfuscate" + parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 5020745..46e1b6a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -7,35 +7,48 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils where -import Control.Exception + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.Data import qualified Data.Foldable as Foldable -import qualified Data.Generics as SYB -import Data.HList.HList import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Set as Set -import GHC (GenLocated(L)) -import qualified GHC hiding (parseModule) -import GHC.Data.Bag -import qualified GHC.Driver.CmdLine as GHC -import qualified GHC.Driver.Session as GHC -import GHC.Hs -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.SrcLoc (Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified System.IO +import Language.Haskell.Brittany.Internal.Config.Types +import Data.Data +import Data.HList.HList + +import GHC ( GenLocated(L) ) +import qualified GHC.Driver.Session as GHC +import qualified GHC hiding (parseModule) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Driver.CmdLine as GHC + +import GHC.Hs +import GHC.Data.Bag + +import GHC.Types.SrcLoc ( SrcSpan, Located ) + + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint + +import qualified Data.Generics as SYB + +import Control.Exception +-- import Data.Generics.Schemes + + + parseModule :: [String] -> System.IO.FilePath @@ -54,7 +67,7 @@ parseModuleWithCpp -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleWithCpp cpp opts args fp dynCheck = ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ GHC.getSessionDynFlags + dflags0 <- lift $ GHC.getSessionDynFlags (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> ("-hide-all-packages" : args)) @@ -66,20 +79,17 @@ parseModuleWithCpp cpp opts args fp dynCheck = void $ lift $ GHC.setSessionDynFlags dflags1 dflags2 <- lift $ ExactPrint.initDynFlags fp unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " + $ ExceptT.throwE + $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " + $ ExceptT.throwE + $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) - x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 + x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp - either - (\err -> ExceptT.throwE $ "transform error: " ++ show - (bagToList (show <$> err)) - ) - (\(a, m) -> pure (a, m, x)) + either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) + (\(a, m) -> pure (a, m, x)) $ ExactPrint.postParseTransform res opts parseModuleFromString @@ -97,51 +107,46 @@ parseModuleFromString args fp dynCheck str = -- bridoc transformation stuff. -- (reminder to update note on `parsePrintModule` if this changes.) mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do - dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str + dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) unless (null leftover) - $ ExceptT.throwE - $ "when parsing ghc flags: leftover flags: " + $ ExceptT.throwE + $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) unless (null warnings) - $ ExceptT.throwE - $ "when parsing ghc flags: encountered warnings: " + $ ExceptT.throwE + $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> warnExtractorCompat) dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of - Left err -> - ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) - Right (a, m) -> pure (a, m, dynCheckRes) + Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) + Right (a , m ) -> pure (a, m, dynCheckRes) commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob ast = do - let - extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` (\l@(L span _) -> - Seq.singleton (span, ExactPrint.mkAnnKey l) - ) + let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` + (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) let nodes = SYB.everything (<>) extract ast - let - annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] + let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (const id) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes + ] nodes `forM_` (snd .> processComs annsMap) where processComs annsMap annKey1 = do mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn `forM_` \ann1 -> do - let - priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 + let priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 let processCom :: (ExactPrint.Comment, ExactPrint.DeltaPos) @@ -153,32 +158,31 @@ commentAnnFixTransformGlob ast = do (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> move $> False (x, y) | x == y -> move $> False - _ -> return True + _ -> return True where ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 move = ExactPrint.modifyAnnsT $ \anns -> let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2' = ann2 { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] + ExactPrint.annFollowingComments ann2 ++ [comPair] } - in Map.insert annKey2 ann2' anns + in + Map.insert annKey2 ann2' anns _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors + priors' <- filterM processCom priors follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case + assocs' <- flip filterM assocs $ \case (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let - ann1' = ann1 - { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } + _ -> return True + let ann1' = ann1 { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns @@ -266,30 +270,29 @@ extractToplevelAnns lmod anns = output | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns ] declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + modKey = ExactPrint.mkAnnKey lmod + output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) -groupMap f = Map.foldlWithKey' - (\m k a -> Map.alter (insert k a) (f k a) m) - Map.empty +groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) + Map.empty where - insert k a Nothing = Just (Map.singleton k a) + insert k a Nothing = Just (Map.singleton k a) insert k a (Just m) = Just (Map.insert k a m) foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys ast = SYB.everything Set.union - (\x -> maybe + ( \x -> maybe Set.empty Set.singleton [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x - ] -- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- even though it is passed to mkAnnKey above, which only accepts -- SrcSpan. + ] ) ast where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) @@ -298,8 +301,8 @@ foldedAnnKeys ast = SYB.everything withTransformedAnns :: Data ast => ast - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case readers@(conf :+: anns :+: HNil) -> do -- TODO: implement `local` for MultiReader/MultiRWS @@ -309,10 +312,9 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case pure x where f anns = - let - ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced + let ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced warnExtractorCompat :: GHC.Warn -> String diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 8f861d4..422c7be 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -6,37 +6,50 @@ module Language.Haskell.Brittany.Internal.LayouterBasics where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Writer.Strict as Writer -import qualified Data.Char as Char -import Data.Data import qualified Data.Map as Map import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import DataTreePrint -import GHC (GenLocated(L), Located, moduleName, moduleNameString) import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.Name (getOccString) -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader (RdrName(..)) -import qualified GHC.Types.SrcLoc as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import qualified Control.Monad.Writer.Strict as Writer + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import GHC.Types.Name.Reader ( RdrName(..) ) +import GHC ( Located, GenLocated(L), moduleName, moduleNameString ) +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name ( getOccString ) +import GHC.Parser.Annotation ( AnnKeywordId(..) ) + +import Data.Data + +import qualified Data.Char as Char + +import DataTreePrint + + + processDefault :: ( ExactPrint.Annotate.Annotate ast , MonadMultiWriter Text.Builder.Builder m @@ -54,7 +67,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString str + _ -> mTell $ Text.Builder.fromString str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -66,10 +79,9 @@ briDocByExact -> ToBriDocM BriDocNumbered briDocByExact ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns True -- | Use ExactPrint's output for this node. @@ -83,10 +95,9 @@ briDocByExactNoComment -> ToBriDocM BriDocNumbered briDocByExactNoComment ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns False -- | Use ExactPrint's output for this node, presuming that this output does @@ -99,26 +110,24 @@ briDocByExactInlineOnly -> ToBriDocM BriDocNumbered briDocByExactInlineOnly infoStr ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let - exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t - let - errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + let exactPrintNode t = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + t + let errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit + $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _) -> errorAction - (_, [t]) -> exactPrintNode + (ExactPrintFallbackModeNever, _ ) -> errorAction + (_ , [t]) -> exactPrintNode (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted _ -> errorAction @@ -143,21 +152,20 @@ lrdrNameToTextAnnGen lrdrNameToTextAnnGen f ast@(L _ n) = do anns <- mAsk let t = f $ rdrNameToText n - let - hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False + let hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. -- whatever we don't probably should have had some effect on the -- output. in such cases, resorting to byExact is probably the safe -- choice. return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t + Nothing -> t Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t lrdrNameToTextAnn :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) @@ -170,10 +178,9 @@ lrdrNameToTextAnnTypeEqualityIsSpecial => Located RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let - f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + let f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x lrdrNameToTextAnnGen f ast -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects @@ -191,11 +198,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick -> m Text lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let - lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + x <- lrdrNameToTextAnn ast2 + let lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x return $ if hasQuote then Text.cons '\'' lit else lit askIndent :: (MonadMultiReader Config m) => m Int @@ -213,11 +219,12 @@ extractRestComments ann = ExactPrint.annFollowingComments ann ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] + _ -> [] ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +filterAnns ast = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) -- | True if there are any comments that are -- a) connected to any node below (in AST sense) the given node AND @@ -235,16 +242,15 @@ hasCommentsBetween -> ToBriDocM Bool hasCommentsBetween ast leftKey rightKey = do mAnn <- astAnn ast - let - go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest + let go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest case mAnn of - Nothing -> pure False + Nothing -> pure False Just ann -> pure $ go1 $ ExactPrint.annsDP ann -- | True if there are any comments that are connected to any node below (in AST @@ -254,8 +260,7 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast -- | True if there are any regular comments connected to any node below (in AST -- sense) the given node -hasAnyRegularCommentsConnected - :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyRegularCommentsConnected ast = any isRegularComment <$> astConnectedComments ast @@ -292,7 +297,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False + Nothing -> False Just ann -> any hasK (extractAllComments ann) where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst @@ -306,7 +311,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks where hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False + hasK _ = False astAnn :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) @@ -455,10 +460,12 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) deriving (Functor, Applicative, Monad) addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = when cond (addAlternative doc) +addAlternativeCond cond doc = + when cond (addAlternative doc) addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = CollectAltM . Writer.tell . (: []) +addAlternative = + CollectAltM . Writer.tell . (: []) runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative (CollectAltM action) = @@ -475,8 +482,7 @@ docLines l = allocateNode . BDFLines =<< sequence l docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docCols sig l = allocateNode . BDFCols sig =<< sequence l -docAddBaseY - :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -511,8 +517,7 @@ docAnnotationKW -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = - allocateNode . BDFAnnotationKW annKey kw =<< bdm +docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docMoveToKWDP :: AnnKey @@ -564,7 +569,7 @@ docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] docParenHashRSep :: ToBriDocM BriDocNumbered docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] @@ -626,26 +631,32 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNodePrior ast bdm = do bd <- bdm i1 <- allocNodeIndex - return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd + return + $ (,) i1 + $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ bd docWrapNodeRest ast bdm = do bd <- bdm i2 <- allocNodeIndex - return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd + return + $ (,) i2 + $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) + $ bd instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where docWrapNode ast bdms = case bdms of [] -> [] [bd] -> [docWrapNode ast bd] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdms = case bdms of [] -> [] [bd] -> [docWrapNodePrior ast bd] - (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR + (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + [] -> [] + (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do @@ -655,25 +666,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ [bd1'] ++ reverse bdM ++ [bdN'] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdsm = do bds <- bdsm case bds of [] -> return [] - (bd1 : bdR) -> do + (bd1:bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return (bd1' : bdR) + return (bd1':bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of [] -> return [] - (bdN : bdR) -> do + (bdN:bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN' : bdR) + return $ reverse (bdN':bdR) instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do @@ -686,7 +697,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where return $ Seq.singleton bd1' bdM Seq.:> bdN -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ (bd1' Seq.<| bdM) Seq.|> bdN' docWrapNodePrior ast bdsm = do bds <- bdsm @@ -730,7 +741,7 @@ docPar -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docPar lineM indentedM = do - line <- lineM + line <- lineM indented <- indentedM allocateNode $ BDFPar BrIndentNone line indented @@ -767,15 +778,14 @@ briDocMToPPM m = do briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR - let - ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m + let ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 3bafd56..acbe186 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -3,19 +3,26 @@ module Language.Haskell.Brittany.Internal.Layouters.DataDecl where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (GenLocated(L), Located) -import qualified GHC -import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( Located, GenLocated(L) ) +import qualified GHC +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Layouters.Type + + layoutDataDecl :: Located (TyClDecl GhcPs) @@ -25,29 +32,28 @@ layoutDataDecl -> ToBriDocM BriDocNumbered layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> - case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) - -> docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> + docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl -- data MyData a b @@ -55,8 +61,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "data" , lhsContextDoc @@ -68,36 +74,32 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- data MyData = MyData { .. } HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) - -> docWrapNode ltycl $ do + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> + docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing + Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- return <$> createDetailsDoc consNameStr details - consDoc <- - fmap pure + rhsDoc <- return <$> createDetailsDoc consNameStr details + consDoc <- fmap pure $ docNonBottomSpacing $ case (forallDocMay, rhsContextDocMay) of (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq - [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [ docLitS "." , docSeparator - , docSetBaseY - $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] ] (Just forallDoc, Nothing) -> docLines - [ docSeq - [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [docLitS ".", docSeparator, rhsDoc] ] (Nothing, Just rhsContextDoc) -> docSeq @@ -105,12 +107,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSeparator , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] - (Nothing, Nothing) -> - docSeq [docLitS "=", docSeparator, rhsDoc] + (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline $ lhsContextDoc , appSep $ docLit nameStr @@ -122,13 +124,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> - docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -136,26 +137,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr , tyVarLine ] ) - (docSeq + ( docSeq [ docLitS "=" , docSeparator , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> - docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -166,7 +167,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -187,10 +189,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- hurt. docAddBaseY BrIndentRegular $ docPar (docLitS "data") - (docLines + ( docLines [ lhsContextDoc , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq [appSep $ docLit nameStr, tyVarLine] + $ docSeq + [ appSep $ docLit nameStr + , tyVarLine + ] , consDoc ] ) @@ -204,20 +209,20 @@ createContextDoc [] = docEmpty createContextDoc [t] = docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 + t1Doc <- docSharedWrapper layoutType t1 tRDocs <- tR `forM` docSharedWrapper layoutType docAlt [ docSeq [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse - docCommaSep - (t1Doc : tRDocs) + , docForceSingleline $ docSeq $ List.intersperse docCommaSep + (t1Doc : tRDocs) , docLitS ") =>" , docSeparator ] , docLines $ join [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , tRDocs + <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] , [docLitS ") =>", docSeparator] ] ] @@ -229,18 +234,20 @@ createBndrDoc bs = do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) - docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> - case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -249,47 +256,48 @@ createDerivingPar derivs mainDoc = do (L _ []) -> mainDoc (L _ types) -> docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = - case types of - (L _ []) -> docSeq [] - (L _ ts) -> - let - tsLength = length ts - whenMoreThan1Type val = - if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = - maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in docSeq +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = + if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in + docSeq [ docDeriving , docWrapNodePrior types $ lhsStrategy , docSeparator , whenMoreThan1Type "(" , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts - <&> \case - HsIB _ t -> layoutType t + $ docSeq + $ List.intersperse docCommaSep + $ ts <&> \case + HsIB _ t -> layoutType t , whenMoreThan1Type ")" , rhsStrategy ] where strategyLeftRight = \case - (L _ StockStrategy) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes)) -> + (L _ StockStrategy ) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) + lVia@(L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of - HsIB _ext t -> docSeq - [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] + HsIB _ext t -> docSeq + [ docWrapNode lVia $ docLitS " via" + , docSeparator + , layoutType t + ] ) docDeriving :: ToBriDocM BriDocNumbered @@ -299,25 +307,21 @@ createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of PrefixCon args -> do - indentPolicy <- - mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq [ docLit consNameStr , docSeparator , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ fmap hsScaledThing args - <&> layoutType + $ docSeq + $ List.intersperse docSeparator + $ fmap hsScaledThing args <&> layoutType ] - leftIndented = - docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType - <$> fmap hsScaledThing args + leftIndented = docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType <$> fmap hsScaledThing args multiAppended = docSeq [ docLit consNameStr , docSeparator @@ -327,80 +331,79 @@ createDetailsDoc consNameStr details = case details of (docLit consNameStr) (docLines $ layoutType <$> fmap hsScaledThing args) case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyFree -> docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> - docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_ : _)) -> do + RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_:_)) -> do let ((fName1, fType1) : fDocR) = mkFieldDocs fields -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False - docAddBaseY BrIndentRegular $ runFilteredAlternative $ do + docAddBaseY BrIndentRegular + $ runFilteredAlternative + $ do -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" - ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols - ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 - , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 - ] - , docSeq - [ docLitS "{" - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) - ] - ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols - ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] + , docSeparator , docLitS "}" ] - ) + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName + , docSeq [docLitS "::", docSeparator] + , docForceSingleline fType + ] + , docSeq + [ docLitS "," + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName + (docSeq [docLitS "::", docSeparator, fType]) + ] + ] + , docLitS "}" + ] + ) InfixCon arg1 arg2 -> docSeq [ layoutType $ hsScaledThing arg1 , docSeparator @@ -415,11 +418,10 @@ createDetailsDoc consNameStr details = case details of mkFieldDocs = fmap $ \lField -> case lField of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t -createForallDoc - :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = - Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] +createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = Just $ docSeq + [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc :: Data.Data.Data ast @@ -429,8 +431,12 @@ createNamesAndTypeDoc -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq $ List.intersperse docCommaSep $ names <&> \case - L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \case + L _ (FieldOcc _ fieldName) -> + docLit =<< lrdrNameToTextAnn fieldName ] , docWrapNodeRest lField $ layoutType t ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index c2ff209..a96ae47 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -5,46 +5,56 @@ module Language.Haskell.Brittany.Internal.Layouters.Decl where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Foldable import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Data.Bag (bagToList, emptyBag) -import qualified GHC.Data.FastString as FastString -import GHC.Hs import qualified GHC.OldList as List -import GHC.Types.Basic - ( Activation(..) - , InlinePragma(..) - , InlineSpec(..) - , LexicalFixity(..) - , RuleMatchInfo(..) - ) -import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Layouters.Type + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import GHC ( GenLocated(L) + , AnnKeywordId(..) + ) +import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc ) +import qualified GHC.Data.FastString as FastString +import GHC.Hs +import GHC.Types.Basic ( InlinePragma(..) + , Activation(..) + , InlineSpec(..) + , RuleMatchInfo(..) + , LexicalFixity(..) + ) +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.DataDecl + +import GHC.Data.Bag ( bagToList, emptyBag ) + + layoutDecl :: ToBriDoc HsDecl layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> @@ -57,61 +67,52 @@ layoutDecl d@(L loc decl) = case decl of layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> - layoutNamesAndType Nothing names typ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig spec - let - phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let - conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " + let phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> - layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> - layoutNamesAndType (Just "pattern") names typ + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ + PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ _ -> briDocByExactNoComment lsig -- TODO where layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let - keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] + let keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- - mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack + shouldBeHanging <- mAsk + <&> _conf_layout + .> _lconfig_hangingTypeSignature + .> confUnpack if shouldBeHanging - then - docSeq - $ [ appSep - $ docWrapNodeRest lsig - $ docSeq - $ keyDoc - <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ] + then docSeq $ + [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc ] + ] + ] else layoutLhsAndType hasComments (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) @@ -121,23 +122,22 @@ layoutSig lsig@(L _loc sig) = case sig of specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body + BodyStmt _ body _ _ -> layoutExpr body BindStmt _ lPat expr -> do patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr - docCols - ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO + docCols ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- @@ -145,33 +145,37 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -------------------------------------------------------------------------------- layoutBind - :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) + :: ToBriDocC + (HsBindLR GhcPs GhcPs) + (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" funcPatDocs <- docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches return $ Left $ funcPatDocs PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat + patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" + binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal - Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereArg + hasComments PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID + lpat + dir + rpat _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of @@ -181,13 +185,7 @@ layoutIPBind lipbind@(L _ bind) = case bind of binderDoc <- docLit $ Text.pack "=" exprDoc <- layoutExpr expr hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal - Nothing - binderDoc - (Just ipName) - [([], exprDoc, expr)] - Nothing - hasComments + layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) @@ -195,7 +193,7 @@ data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) @@ -205,18 +203,18 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let - unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + let unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s + BagSig s -> return <$> layoutSig s return $ Just $ docs -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb + HsIPBinds _ (IPBinds _ bb) -> + Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is @@ -226,7 +224,7 @@ layoutGrhs -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body + bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) layoutPatternBind @@ -235,7 +233,7 @@ layoutPatternBind -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match + let pats = m_pats match let (GRHSs _ grhss whereBinds) = m_grhss match patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match @@ -244,26 +242,25 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1 : p2 : pr) | isInfix -> if null pr - then docCols - ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else docCols - ColPatternsFuncInfix - ([ docCols - ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR + (Just idStr, p1:p2:pr) | isInfix -> if null pr + then + docCols ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else + docCols ColPatternsFuncInfix + ( [docCols ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR + ] ] - ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix @@ -277,30 +274,30 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal - alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments + layoutPatternBindFinal alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereArg + hasComments -fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier + :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match where go = \case - (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr + (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1) -> goInner ctx1 - _ -> idStr + (StmtCtxt ctx1 ) -> goInner ctx1 + _ -> idStr -- I have really no idea if this path ever occurs, but better safe than -- risking another "drop bangpatterns" bugs. goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr + _ -> idStr layoutPatternBindFinal :: Maybe Text @@ -311,304 +308,304 @@ layoutPatternBindFinal -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments - = do - let - patPartInline = case mPatDoc of - Nothing -> [] +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do + let patPartInline = case mPatDoc of + Nothing -> [] Just patDoc -> [appSep $ docForceSingleline $ return patDoc] patPartParWrap = case mPatDoc of - Nothing -> id + Nothing -> id Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- - mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack - regularIndentAmount <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt - [ docEnsureIndent BrIndentRegular $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False + whereIndent <- do + shouldSpecial <- mAsk + <&> _conf_layout + .> _lconfig_indentWhereSpecial + .> confUnpack + regularIndentAmount <- mAsk + <&> _conf_layout + .> _lconfig_indentAmount + .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + [ docEnsureIndent BrIndentRegular + $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docMoveToKWDP annKeyWhere AnnWhere False $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let - singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty + ] + ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> - docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse - docCommaSep - (docForceSingleline . return <$> gs) + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + gs -> docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ (List.intersperse docCommaSep + (docForceSingleline . return <$> gs) ) wherePart = case mWhereDocs of - Nothing -> Just docEmpty + Nothing -> Just docEmpty Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] - _ -> Nothing + _ -> Nothing - indentPolicy <- - mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack - runFilteredAlternative $ do + runFilteredAlternative $ do - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' - ] + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine + ] + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ (case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline $ docSeq - [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - (case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline $ docSeq - [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - (case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1 : gr) -> - (docSeq [appSep $ docLit $ Text.pack "|", return g1] - : (gr - <&> \g -> docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc - ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) ] - ] - ++ wherePartMultiLine + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1:gr) -> + ( docSeq [appSep $ docLit $ Text.pack "|", return g1] + : ( gr + <&> \g -> + docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine -- | Layout a pattern synonym binding layoutPatSynBind @@ -618,51 +615,44 @@ layoutPatSynBind -> LPat GhcPs -> ToBriDocM BriDocNumbered layoutPatSynBind name patSynDetails patDir rpat = do - let - patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" + let patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir - headDoc <- - fmap pure - $ docSeq - $ [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] + headDoc <- fmap pure $ docSeq $ + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] runFilteredAlternative $ do - addAlternative - $ + addAlternative $ -- pattern .. where -- .. -- .. - docAddBaseY BrIndentRegular - $ docSeq - ([headDoc, docSeparator, body] ++ case mWhereDocs of + docAddBaseY BrIndentRegular $ docSeq + ( [headDoc, docSeparator, body] + ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] - ) - addAlternative - $ + ) + addAlternative $ -- pattern .. = -- .. -- pattern .. <- -- .. where -- .. -- .. - docAddBaseY BrIndentRegular - $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> - docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) - ) + docAddBaseY BrIndentRegular $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) + ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn @@ -681,21 +671,18 @@ layoutLPatSyn name (InfixCon left right) = do layoutLPatSyn name (RecCon recArgs) = do docName <- lrdrNameToTextAnn name args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq - . fmap docLit - $ [docName, Text.pack " { "] + docSeq . fmap docLit + $ [docName, Text.pack " { " ] <> intersperse (Text.pack ", ") args <> [Text.pack " }"] -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms -layoutPatSynWhere - :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG _ (L _ lbinds) _) -> do binderDoc <- docLit $ Text.pack "=" - Just - <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing -------------------------------------------------------------------------------- @@ -705,10 +692,9 @@ layoutPatSynWhere hs = case hs of layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl _ name vars fixity typ -> do - let - isInfix = case fixity of - Prefix -> False - Infix -> True + let isInfix = case fixity of + Prefix -> False + Infix -> True -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl @@ -737,7 +723,9 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do -- This isn't quite right, but does give syntactically valid results let needsParens = not (null rest) || hasOwnParens docSeq - $ [docLit $ Text.pack "type", docSeparator] + $ [ docLit $ Text.pack "type" + , docSeparator + ] ++ [ docParenL | needsParens ] ++ [ layoutTyVarBndr False a , docSeparator @@ -749,13 +737,13 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do ++ fmap (layoutTyVarBndr True) rest else docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc @@ -764,11 +752,11 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name - docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] + docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] KindedTyVar _ _ name kind -> do nameStr <- lrdrNameToTextAnn name docSeq - $ [ docSeparator | needsSep ] + $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" @@ -796,7 +784,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name + nameStr <- lrdrNameToTextAnn name needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass @@ -807,35 +795,33 @@ layoutTyFamInstDecl inClass outerNode tfid = do makeForallDoc bndrs = do bndrDocs <- layoutTyVarBndrs bndrs docSeq - ([docLit (Text.pack "forall")] + ( [docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs ) lhs = docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] + . docSeq + $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] - hasComments <- - (||) + hasComments <- (||) <$> hasAnyRegularCommentsConnected outerNode <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc -layoutHsTyPats - :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm + HsValArg tm -> layoutType tm HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change -- is a bit strange. Hopefully this does not ignore any important -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" + HsArgPar _l -> error "brittany internal error: HsArgPar{}" -------------------------------------------------------------------------------- -- ClsInstDecl @@ -850,27 +836,27 @@ layoutClsInst :: ToBriDoc ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) ] where layoutInstanceHead :: ToBriDocM BriDocNumbered layoutInstanceHead = briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren <$> lcid removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] , cid_datafam_insts = [] } @@ -878,11 +864,7 @@ layoutClsInst lcid@(L _ cid) = docLines docSortedLines :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = - allocateNode - . BDFLines - . fmap unLoc - . List.sortOn (ExactPrint.rs . getLoc) - =<< sequence l + allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig @@ -894,8 +876,8 @@ layoutClsInst lcid@(L _ cid) = docLines joinBinds :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n + Left ns -> docLines $ return <$> ns + Right n -> return n layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) @@ -961,11 +943,10 @@ layoutClsInst lcid@(L _ cid) = docLines stripWhitespace' t = Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t where - go [] = [] + go [] = [] go (line1 : lineR) = case Text.stripStart line1 of - st - | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR + st | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "newtype" `Text.isPrefixOf` t') @@ -988,12 +969,7 @@ layoutLhsAndType hasComments lhs sep typeDoc = do -- lhs = type -- lhs :: type addAlternativeCond (not hasComments) $ docSeq - [ lhs - , docSeparator - , docLitS sep - , docSeparator - , docForceSingleline typeDoc - ] + [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 3bc4c67..344454c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -4,150 +4,149 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) -import qualified GHC.Data.FastString as FastString -import GHC.Hs import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Types.Name -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( GenLocated(L), SrcSpan, AnnKeywordId(..), RdrName(..) ) +import GHC.Hs +import GHC.Types.Name +import qualified GHC.Data.FastString as FastString +import GHC.Types.Basic + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type + + layoutExpr :: ToBriDoc HsExpr layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk + <&> _conf_layout + .> _lconfig_indentPolicy + .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of HsVar _ vname -> do docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname + HsUnboundVar _ oname -> + docLit $ Text.pack $ occNameString oname HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label + let label = FastString.unpackFS name + in docLit . Text.pack $ '#' : label HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label + let label = FastString.unpackFS name + in docLit . Text.pack $ '?' : label HsOverLit _ olit -> do allocateNode $ overLitValBriDoc $ ol_val olit HsLit _ lit -> do allocateNode $ litBriDoc lit HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds{} <- llocals - , L _ (GRHS _ [] body) <- lgrhs + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds {} <- llocals + , L _ (GRHS _ [] body) <- lgrhs -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let - shouldPrefixSeparator = case p of + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let shouldPrefixSeparator = case p of L _ LazyPat{} -> isFirst L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- - docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let - funcPatternPartLine = docCols - ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let funcPatternPartLine = + docCols ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc ] - HsLam{} -> unknownNodeError "HsLam too complex" lexpr - HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular - $ (docLit $ Text.pack "\\case {}") + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing + $ docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> + unknownNodeError "HsLam too complex" lexpr + HsLamCase _ (MG _ (L _ []) _) -> do + docSetParSpacing $ docAddBaseY BrIndentRegular $ + (docLit $ Text.pack "\\case {}") HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let - gather - :: [LHsExpr GhcPs] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r : list) l - x -> (x, list) + let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) + gather list = \case + L _ (HsApp _ l r) -> gather (r:list) l + x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 - let - colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq + let colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs hasComments <- hasAnyCommentsConnected exp2 @@ -159,13 +158,13 @@ layoutExpr lexpr@(L _ expr) = do : spacifyDocs (docForceSingleline <$> paramDocs) -- foo x -- y - addAlternativeCond allowFreeIndent $ docSeq + addAlternativeCond allowFreeIndent + $ docSeq [ appSep (docForceSingleline headDoc) , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ docForceSingleline - <$> paramDocs + $ docForceSingleline <$> paramDocs ] -- foo -- x @@ -174,25 +173,30 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docForceSingleline headDoc) - (docNonBottomSpacing $ docLines paramDocs) + (docForceSingleline headDoc) + ( docNonBottomSpacing + $ docLines paramDocs + ) -- ( multi -- line -- function -- ) -- x -- y - addAlternative $ docAddBaseY BrIndentRegular $ docPar - headDoc - (docNonBottomSpacing $ docLines paramDocs) + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + headDoc + ( docNonBottomSpacing + $ docLines paramDocs + ) HsApp _ exp1 exp2 -> do -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 docAlt [ -- func arg - docSeq - [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] , -- func argline1 -- arglines -- e.g. @@ -205,70 +209,77 @@ layoutExpr lexpr@(L _ expr) = do -- anyways, so it is _always_ par-spaced. $ docAddBaseY BrIndentRegular $ docSeq - [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] + [ appSep $ docForceSingleline expDoc1 + , docForceParSpacing expDoc2 + ] , -- func -- arg - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar (docForceSingleline expDoc1) (docNonBottomSpacing expDoc2) , -- fu -- nc -- ar -- gument - docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 + docAddBaseY BrIndentRegular + $ docPar + expDoc1 + expDoc2 ] HsAppType _ exp1 (HsWC _ ty1) -> do t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 docAlt [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar e (docSeq [docLit $ Text.pack "@", t]) + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar + e + (docSeq [docLit $ Text.pack "@", t ]) ] OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let - gather - :: [(LHsExpr GhcPs, LHsExpr GhcPs)] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft + let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) + gather opExprList = \case + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x, y) -> - [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight + appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight allowSinglelinePar <- do hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp + hasComOp <- hasAnyCommentsConnected expOp pure $ not hasComLeft && not hasComOp - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True runFilteredAlternative $ do -- > one + two + three -- or -- > one + two + case x of -- > _ -> three - addAlternativeCond allowSinglelinePar $ docSeq + addAlternativeCond allowSinglelinePar + $ docSeq [ appSep $ docForceSingleline leftOperandDoc - , docSeq $ appListDocs <&> \(od, ed) -> docSeq - [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] + , docSeq + $ appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] , appSep $ docForceSingleline opLastDoc , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc + expLastDoc ] -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) @@ -283,31 +294,29 @@ layoutExpr lexpr@(L _ expr) = do -- > one -- > + two -- > + three - addAlternative $ docPar - leftOperandDoc - (docLines - $ (appListDocs <&> \(od, ed) -> - docCols ColOpPrefix [appSep od, docSetBaseY ed] + addAlternative $ + docPar + leftOperandDoc + ( docLines + $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - ) OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let - leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False + let allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line - addAlternative $ docSeq + addAlternative + $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceSingleline expDocRight @@ -322,35 +331,35 @@ layoutExpr lexpr@(L _ expr) = do -- two-line addAlternative $ do let - expDocOpAndRight = docForceSingleline $ docCols - ColOpPrefix - [appSep $ expDocOp, docSetBaseY expDocRight] + expDocOpAndRight = docForceSingleline + $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight + else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight -- TODO: in both cases, we don't force expDocLeft to be -- single-line, which has certain.. interesting consequences. -- At least, the "two-line" label is not entirely -- accurate. -- one-line + par - addAlternativeCond allowPar $ docSeq + addAlternativeCond allowPar + $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceParSpacing expDocRight ] -- more lines addAlternative $ do - let - expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + let expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight + $ docPar expDocLeft expDocOpAndRight NegApp _ op _ -> do opDoc <- docSharedWrapper layoutExpr op - docSeq [docLit $ Text.pack "-", opDoc] + docSeq [ docLit $ Text.pack "-" + , opDoc + ] HsPar _ innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -360,8 +369,7 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack ")" ] , docSetBaseY $ docLines - [ docCols - ColOpPrefix + [ docCols ColOpPrefix [ docLit $ Text.pack "(" , docAddBaseY (BrIndentSpecial 2) innerExpDoc ] @@ -370,33 +378,33 @@ layoutExpr lexpr@(L _ expr) = do ] SectionL _ left op -> do -- TODO: add to testsuite leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple _ args boxity -> do - let - argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e) - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> - docWrapNode arg $ maybe docEmpty layoutExpr exprM + let argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e); + (L _ (Missing NoExtField)) -> (arg, Nothing) + argDocs <- forM argExprs + $ docSharedWrapper + $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM hasComments <- orM - (hasCommentsBetween lexpr AnnOpenP AnnCloseP + ( hasCommentsBetween lexpr AnnOpenP AnnCloseP : map hasAnyCommentsBelow args ) - let - (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) + let (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) case splitFirstLast argDocs of - FirstLastEmpty -> - docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] + FirstLastEmpty -> docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) closeLit + ] FirstLastSingleton e -> docAlt - [ docCols - ColTuple + [ docCols ColTuple [ openLit , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e , closeLit @@ -411,88 +419,74 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [ docSeq - [ docCommaSep - , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) - , closeLit - ] - ] - addAlternative - $ let - start = docCols ColTuples [appSep openLit, e1] - linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] - lineN = docCols - ColTuples - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + addAlternative $ + let + start = docCols ColTuples + [appSep openLit, e1] + linesM = ems <&> \d -> + docCols ColTuples [docCommaSep, d] + lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase _ cExp (MG _ (L _ []) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp docAlt - [ docAddBaseY BrIndentRegular $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] + [ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") ] HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docAlt - [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq + [ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq [ appSep $ docLit $ Text.pack "case" , appSep $ docForceSingleline cExpDoc , docLit $ Text.pack "of" - ] - ) - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) + ]) + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "of") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "of") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) - ) ] HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr + ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr hasComments <- hasAnyCommentsBelow lexpr - let - maySpecialIndent = case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 + let maySpecialIndent = + case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. docSetIndentLevel $ runFilteredAlternative $ do -- if _ then _ else _ - addAlternativeCond (not hasComments) $ docSeq + addAlternativeCond (not hasComments) + $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc , appSep $ docLit $ Text.pack "then" @@ -517,34 +511,25 @@ layoutExpr lexpr@(L _ expr) = do $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq + ( docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) - $ docForceSingleline ifExprDoc - ] - ) + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ]) (docLines [ docAddBaseY BrIndentRegular $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] + $ docNonBottomSpacing $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc + $ docPar (docLit $ Text.pack "then") thenExprDoc ] - ] - ) + , docAddBaseY BrIndentRegular + $ docNonBottomSpacing $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) -- either -- if multi -- line @@ -562,69 +547,62 @@ layoutExpr lexpr@(L _ expr) = do -- else -- stuff -- note that this does _not_ have par-spacing - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - ) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc + addAlternative + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc ] , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + addAlternative + $ docSetBaseY + $ docLines + [ docAddBaseY maySpecialIndent + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc ] - ] - ) - addAlternative $ docSetBaseY $ docLines - [ docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "else") elseExprDoc - ] + ] HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" hasComments <- hasAnyCommentsBelow lexpr docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") - (layoutPatternBindFinal - Nothing - binderDoc - Nothing - clauseDocs - Nothing - hasComments - ) + (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x + ifIndentFreeElse x y = + case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), -- but is here due to ghc-exactprint's DP handling of "let" in @@ -637,35 +615,36 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline - bindDoc + , docNodeAnnKW lexpr (Just AnnLet) + $ appSep $ docForceSingleline bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ] addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc + [ docNodeAnnKW lexpr (Just AnnLet) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) - ] , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse - docSetBaseAndIndent - docForceSingleline - expDoc1 + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 + ] + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY expDoc1) ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) - ] ] - Just bindDocs@(_ : _) -> runFilteredAlternative $ do + Just bindDocs@(_:_) -> runFilteredAlternative $ do --either -- let -- a = b @@ -679,91 +658,102 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - let - noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 + let noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular + $ docForceParSpacing expDoc1 + ] ] - ] addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq + IndentPolicyFree -> docLines + [ docNodeAnnKW lexpr (Just AnnLet) + $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines bindDocs ] - , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY expDoc1 + ] ] - addAlternative $ docLines + addAlternative + $ docLines [ docNodeAnnKW lexpr (Just AnnLet) $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of DoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) MDoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x - | case x of - ListComp -> True - MonadComp -> True - _ -> False - -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq - $ List.intersperse docCommaSep - $ docForceSingleline - <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative - $ let - start = docCols - ColListComp - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack - "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1 : sM) = List.init stmtDocs - line1 = - docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ docNodeAnnKW lexpr Nothing + $ appSep + $ docLit + $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq $ List.intersperse docCommaSep + $ docForceSingleline <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative $ + let + start = docCols ColListComp + [ docNodeAnnKW lexpr Nothing + $ appSep $ docLit $ Text.pack "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1:sM) = List.init stmtDocs + line1 = docCols ColListComp + [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] _ -> do -- TODO unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_ : _) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr + ExplicitList _ _ elems@(_:_) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of FirstLastEmpty -> docSeq @@ -787,106 +777,109 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse - docCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) - ) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) ++ [docLit $ Text.pack "]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> docCols ColList [docCommaSep, d] - lineN = docCols - ColList - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> docLit $ Text.pack "[]" - RecordCon _ lname fields -> case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- - fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- - fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> + docCols ColList [docCommaSep, d] + lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ExplicitList _ _ [] -> + docLit $ Text.pack "[]" + RecordCon _ lname fields -> + case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- fs + `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression False indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just (L _ 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr + recordExpression True indentPolicy lexpr nameDoc fieldDocs + _ -> unknownNodeError "RecordCon with puns" lexpr RecordUpd _ rExpr fields -> do rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- - fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFs <- fields + `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do rFExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ case ambName of Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) recordExpression False indentPolicy lexpr rExprDoc rFs ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 - docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] - ArithSeq _ Nothing info -> case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr + docSeq + [ appSep expDoc + , appSep $ docLit $ Text.pack "::" + , typDoc + ] + ArithSeq _ Nothing info -> + case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> + briDocByExactInlineOnly "ArithSeq" lexpr HsBracket{} -> do -- TODO briDocByExactInlineOnly "HsBracket{}" lexpr @@ -899,12 +892,11 @@ layoutExpr lexpr@(L _ expr) = do HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do allocateNode $ BDFPlain (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]" - ) + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]") HsSpliceE{} -> do -- TODO briDocByExactInlineOnly "HsSpliceE{}" lexpr @@ -936,79 +928,78 @@ recordExpression -> IndentPolicy -> GenLocated SrcSpan lExpr -> ToBriDocM BriDocNumbered - -> [ ( GenLocated SrcSpan name - , Text - , Maybe (ToBriDocM BriDocNumbered) - ) - ] + -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used +recordExpression False _ lexpr nameDoc [] = + docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression True _ lexpr nameDoc [] = + docSeq -- this case might still be incomplete, and is probably not used -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do let (rF1f, rF1n, rF1e) = rF1 runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } - addAlternative $ docSeq + addAlternative + $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr + , docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr , if dotdot - then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator + then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator , docLit $ Text.pack "}" ] -- hanging single-line fields -- container { fieldA = blub -- , fieldB = blub -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docSeq [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY - $ docLines - $ let - line1 = docCols - ColRec + , docSetBaseY $ docLines $ let + line1 = docCols ColRec [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit rF1n , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [appSep $ docLit $ Text.pack "=", docForceSingleline x] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq - [appSep $ docLit $ Text.pack "=", docForceSingleline x] + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] Nothing -> docEmpty - ] + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] + in [line1] ++ lineR ++ [dotdotLine, lineN] ] -- non-hanging with expressions placed to the right of the names -- container @@ -1016,75 +1007,77 @@ recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do -- , fieldB = potentially -- multiline -- } - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing - $ docLines - $ let - line1 = docCols - ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec + addAlternative + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing $ docLines $ let + line1 = docCols ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRec [ docCommaSep , appSep $ docLit fText , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq + [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq [ appSep $ docLit $ Text.pack "=" + , docForceParSpacing x + ] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty ] - dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) + dotdotLine = if dotdot + then docCols ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) + $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ) litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t _ -> error "litBriDoc: literal with no SourceText" overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 27256ef..8fb094b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -2,11 +2,20 @@ module Language.Haskell.Brittany.Internal.Layouters.Expr where -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types + + +import Language.Haskell.Brittany.Internal.Prelude + +import Language.Haskell.Brittany.Internal.Types + +import GHC.Hs + + layoutExpr :: ToBriDoc HsExpr +-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) + litBriDoc :: HsLit GhcPs -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index dc1fafe..39b7a49 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -4,22 +4,26 @@ module Language.Haskell.Brittany.Internal.Layouters.IE where +import Language.Haskell.Brittany.Internal.Prelude import qualified Data.List.Extra import qualified Data.Text as Text -import GHC - ( AnnKeywordId(..) - , GenLocated(L) - , Located - , ModuleName - , moduleNameString - , unLoc - ) -import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + , ModuleName + ) +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Utils + + prepareName :: LIEWrappedName name -> Located name prepareName = ieLWrappedName @@ -33,41 +37,36 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] IEThingWith _ x _ ns _ -> do hasComments <- orM - (hasCommentsBetween lie AnnOpenP AnnCloseP + ( hasCommentsBetween lie AnnOpenP AnnCloseP : hasAnyCommentsBelow x : map hasAnyCommentsBelow ns ) let sortedNs = List.sortOn wrappedNameToText ns runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] + $ docSeq + $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc sortedNs) ++ [docParenR] addAlternative $ docWrapNodeRest lie $ docAddBaseY BrIndentRegular - $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) + $ docPar + (layoutWrapped lie x) + (layoutItems (splitFirstLast sortedNs)) where nameDoc = docLit <=< lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] - , docParenR - ] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] - , docParenR - ] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] layoutItems (FirstLast n1 nMs nN) = docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs - ++ [ docSeq - [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] - , docParenR - ] + ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] IEModuleContents _ n -> docSeq [ docLit $ Text.pack "module" , docSeparator @@ -76,7 +75,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEPattern n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "pattern " <> name @@ -93,36 +92,33 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: SortItemsFlag - -> Located [LIE GhcPs] - -> ToBriDocM [ToBriDocM BriDocNumbered] + :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] - let - sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let - ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies + let sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText + $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] + FirstLastEmpty -> [] FirstLastSingleton ie -> [ie] FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] pure $ fmap pure ieCommaDocs -- returned shared nodes where mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] + mergeGroup [] = [] mergeGroup items@[_] = items - mergeGroup items = if + mergeGroup items = if | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items -- proper means that if it is a ThingWith, it does not contain a wildcard -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). @@ -135,22 +131,21 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True - _ -> False + _ -> False thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{}) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 (L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder l1@(L _ IEVar{} ) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 ( L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l - (IEThingWith - x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) + (IEThingWith x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) ) thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -169,10 +164,9 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs - :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies + ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies runFilteredAlternative $ case ieDs of [] -> do @@ -182,14 +176,14 @@ layoutLLIEs enableSingleline shouldSort llies = do docParenR (ieDsH : ieDsT) -> do addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] + $ docSeq + $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) ++ [docParenR] addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT ++ [docParenR] -- | Returns a "fingerprint string", not a full text representation, nor even @@ -197,27 +191,26 @@ layoutLLIEs enableSingleline shouldSort llies = do -- Used for sorting, not for printing the formatter's output source code. wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n + L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. lieToText :: LIE GhcPs -> Text lieToText = \case - L _ (IEVar _ wn) -> wrappedNameToText wn - L _ (IEThingAbs _ wn) -> wrappedNameToText wn - L _ (IEThingAll _ wn) -> wrappedNameToText wn + L _ (IEVar _ wn ) -> wrappedNameToText wn + L _ (IEThingAbs _ wn ) -> wrappedNameToText wn + L _ (IEThingAll _ wn ) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn -- TODO: These _may_ appear in exports! -- Need to check, and either put them at the top (for module) or do some -- other clever thing. L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" where moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = - Text.pack ("@IEModuleContents" ++ moduleNameString name) + moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index df9d00f..1b19145 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -2,18 +2,26 @@ module Language.Haskell.Brittany.Internal.Layouters.Import where -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L), Located, moduleNameString, unLoc) -import GHC.Hs -import GHC.Types.Basic -import GHC.Unit.Types (IsBootInterface(..)) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , Located + ) +import GHC.Hs +import GHC.Types.Basic +import GHC.Unit.Types (IsBootInterface(..)) + + prepPkg :: SourceText -> String prepPkg rawN = case rawN of @@ -28,132 +36,111 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered layoutImport importD = case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- - mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- - mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let - compact = indentPolicy /= IndentPolicyFree + compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = - let - qualifiedPart = if q /= NotQualified then length "qualified " else 0 - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = case src of - IsBoot -> length "{-# SOURCE #-} " - NotBoot -> 0 - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal + let qualifiedPart = if q /= NotQualified then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength + asCost = length "as " + hidingParenCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" - , case src of - IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}" - NotBoot -> docEmpty + , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty - , if q /= NotQualified - then appSep $ docLit $ Text.pack "qualified" - else docEmpty + , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty , maybe docEmpty (appSep . docLit) pkgNameT ] indentName = if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = indentName $ appSep $ docLit modNameT - hidDocCol = - if hiding then importCol - hidingParenCost else importCol - 2 + modNameD = + indentName $ appSep $ docLit modNameT + hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = - if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + hidDoc = if hiding + then appSep $ docLit $ Text.pack "hiding" + else docEmpty importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of + bindingsD = case mllies of Nothing -> docEmpty Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docAlt - [ docSeq - [ hidDoc - , docForceSingleline $ layoutLLIEs True ShouldSortItems llies - ] - , let - makeParIfHiding = if hiding + then docAlt + [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] + , let makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq - [hidDoc, docParenLSep, docWrapNode llies docEmpty] - ) - (docEnsureIndent - (BrIndentSpecial hidDocColDiff) - docParenR - ) - else docSeq - [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD] - ) - (docEnsureIndent - (BrIndentSpecial hidDocColDiff) - docParenR - ) - -- ..[hiding].( b - -- , b' - -- ) - (ieD : ieDs') -> docPar - (docSeq - [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] - ) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + ] + else do + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + ( docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in - docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular - $ docPar (docSeq [importHead, asDoc]) bindingsD - ] - else case masT of + then + let asDoc = maybe docEmpty makeAsDoc masT + in docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular $ + docPar (docSeq [importHead, asDoc]) bindingsD + ] + else + case masT of Just n -> if enoughRoom - then docLines [docSeq [importHead, asDoc], bindingsD] + then docLines + [ docSeq [importHead, asDoc], bindingsD] else docLines [importHead, asDoc, bindingsD] where enoughRoom = nameCost < importAsCol - asCost - asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n + asDoc = + docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) + $ makeAsDoc n Nothing -> if enoughRoom then docSeq [importHead, bindingsD] else docLines [importHead, bindingsD] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index efae541..52c2cd1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -3,27 +3,34 @@ module Language.Haskell.Brittany.Internal.Layouters.Module where +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) -import GHC.Hs import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types - (DeltaPos(..), commentContents, deltaRow) + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import GHC.Hs +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types + ( DeltaPos(..) + , deltaRow + , commentContents + ) + + layoutModule :: ToBriDoc' HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do + HsModule _ Nothing _ imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) @@ -34,38 +41,43 @@ layoutModule lmod@(L _ mod') = case mod' of -- groupify commentedImports `forM_` tellDebugMessShow -- sortedImports <- sortImports imports let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- - mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack + allowSingleLineExportList <- mAsk + <&> _conf_layout + .> _lconfig_allowSingleLineExportList + .> confUnpack -- the config should not prevent single-line layout when there is no -- export list - let - allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les + let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les docLines $ docSeq [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative $ docLines + addAlternativeCond allowSingleLine $ + docForceSingleline + $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + addAlternative + $ docLines [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) - (docSeq - [ docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docSeq [ + docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + ) ] ] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] @@ -77,7 +89,7 @@ data CommentedImport instance Show CommentedImport where show = \case - EmptyLine -> "EmptyLine" + EmptyLine -> "EmptyLine" IndependentComment _ -> "IndependentComment" ImportStatement r -> "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show @@ -90,9 +102,8 @@ data ImportStatementRecord = ImportStatementRecord } instance Show ImportStatementRecord where - show r = - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) + show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) transformToCommentedImport :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] @@ -110,11 +121,10 @@ transformToCommentedImport is = do accumF accConnectedComm (annMay, decl) = case annMay of Nothing -> ( [] - , [ ImportStatement ImportStatementRecord - { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } + , [ ImportStatement ImportStatementRecord { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } ] ) Just ann -> @@ -126,7 +136,7 @@ transformToCommentedImport is = do :: [(Comment, DeltaPos)] -> [(Comment, DeltaPos)] -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) + go acc [] = ([], acc, 0) go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs go acc ((c1, DP (y, x)) : xs) = @@ -143,8 +153,8 @@ transformToCommentedImport is = do , convertedIndependentComments ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm , importStatement = decl } ] @@ -158,14 +168,14 @@ sortCommentedImports = where unpackImports :: [CommentedImport] -> [CommentedImport] unpackImports xs = xs >>= \case - l@EmptyLine -> [l] + l@EmptyLine -> [l] l@IndependentComment{} -> [l] ImportStatement r -> map IndependentComment (commentsBefore r) ++ [ImportStatement r] mergeGroups :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] mergeGroups xs = xs >>= \case - Left x -> [x] + Left x -> [x] Right y -> ImportStatement <$> y sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups = @@ -175,23 +185,25 @@ sortCommentedImports = groupify cs = go [] cs where go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest + (l@EmptyLine : rest) -> Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] + (ImportStatement r : rest) -> go [r] rest + [] -> [] go acc = \case (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : Right (reverse acc) : go [] rest (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] + [] -> [Right (reverse acc)] commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered commentedImportsToDoc = \case EmptyLine -> docLitS "" IndependentComment c -> commentToDoc c - ImportStatement r -> docSeq - (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) + ImportStatement r -> + docSeq + ( layoutImport (importStatement r) + : map commentToDoc (commentsAfter r) + ) where - commentToDoc (c, DP (_y, x)) = - docLitS (replicate x ' ' ++ commentContents c) + commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 88a10e4..4b99bca 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -3,19 +3,28 @@ module Language.Haskell.Brittany.Internal.Layouters.Pattern where + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import qualified Data.Text as Text -import GHC (GenLocated(L), ol_val) -import GHC.Hs import qualified GHC.OldList as List -import GHC.Types.Basic -import Language.Haskell.Brittany.Internal.LayouterBasics + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import GHC ( GenLocated(L) + , ol_val + ) +import GHC.Hs +import GHC.Types.Basic + import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Layouters.Type + + -- | layouts patterns (inside function bindings, case alternatives, let -- bindings or do notation). E.g. for input @@ -29,15 +38,17 @@ import Language.Haskell.Brittany.Internal.Types -- the different cases below. layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr - VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n + VarPat _ n -> + fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit + LitPat _ lit -> + fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr ParPat _ inner -> do -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" + left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" innerDocs <- colsWrapPat =<< layoutPat inner return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right @@ -63,9 +74,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return <$> docLit nameDoc else do x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap - colsWrapPat - argDocs + xR <- fmap Seq.fromList + $ sequence + $ spacifyDocs + $ fmap colsWrapPat argDocs return $ x1 Seq.<| xR ConPat _ lname (InfixCon left right) -> do -- a :< b -> expr @@ -78,7 +90,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do + ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname @@ -91,34 +103,37 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName + , docSeq $ List.intersperse docCommaSep + $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName , docSeparator , docLit $ Text.pack "}" ] ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname - Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"] - ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) - | dotdoti == length fs -> do + Seq.singleton <$> docSeq + [ appSep $ docLit t + , docLit $ Text.pack "{..}" + ] + ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case (fieldName, Just fieldDoc) -> [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" @@ -126,13 +141,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docCommaSep ] (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] + , docLit $ Text.pack "..}" + ] TuplePat _ args boxity -> do -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR + Boxed -> wrapPatListy args "()" docParenL docParenR Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep AsPat _ asName asPat -> do -- bind@nestedpat -> expr @@ -169,11 +184,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of wrapPatPrepend pat1 (docLit $ Text.pack "~") NPat _ llit@(L _ ol) mNegative _ -> do -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val - ol + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] + Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat @@ -182,7 +196,9 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend - :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) + :: LPat GhcPs + -> ToBriDocM BriDocNumbered + -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of @@ -204,5 +220,8 @@ wrapPatListy elems both start end = do x1 Seq.:< rest -> do sDoc <- start eDoc <- end - rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd] + rest' <- rest `forM` \bd -> docSeq + [ docCommaSep + , return bd + ] return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 528853a..95f7273 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -4,19 +4,26 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L)) -import GHC.Hs -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as Text -import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC ( GenLocated(L) + ) +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Decl import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern + + layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt lstmt@(L _ stmt) = do @@ -46,12 +53,12 @@ layoutStmt lstmt@(L _ stmt) = do ] ] LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree + let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" + Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [bindDoc] -> docAlt [ -- let bind = expr docCols @@ -61,10 +68,9 @@ layoutStmt lstmt@(L _ stmt) = do f = case indentPolicy of IndentPolicyFree -> docSetBaseAndIndent IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple - | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc + IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc ] , -- let -- bind = expr @@ -78,11 +84,10 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (isFree || indentFourPlus) $ docSeq [ appSep $ docLit $ Text.pack "let" - , let - f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs + , let f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs ] -- let -- aaa = expra @@ -90,9 +95,8 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (not indentFourPlus) $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + $ docPar (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index fbba444..02b388c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -2,7 +2,14 @@ module Language.Haskell.Brittany.Internal.Layouters.Stmt where -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types + + +import Language.Haskell.Brittany.Internal.Prelude + +import Language.Haskell.Brittany.Internal.Types + +import GHC.Hs + + layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 7ccb461..ed0dd26 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -3,18 +3,28 @@ module Language.Haskell.Brittany.Internal.Layouters.Type where -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Utils.Outputable (ftext, showSDocUnsafe) -import Language.Haskell.Brittany.Internal.LayouterBasics + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - (FirstLastView(..), splitFirstLast) +import qualified Data.Text as Text +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Utils + ( splitFirstLast + , FirstLastView(..) + ) + +import GHC ( GenLocated(L) + , AnnKeywordId (..) + ) +import GHC.Hs +import GHC.Utils.Outputable ( ftext, showSDocUnsafe ) +import GHC.Types.Basic + + layoutType :: ToBriDoc HsType layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of @@ -22,66 +32,76 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsTyVar _ promoted name -> do t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of - IsPromoted -> - docSeq [docSeparator, docTick, docWrapNode name $ docLit t] + IsPromoted -> docSeq + [ docSeparator + , docTick + , docWrapNode name $ docLit t + ] NotPromoted -> docWrapNode name $ docLit t HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do let bndrs = getBinders hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs forallDoc = docAlt - [ let open = docLit $ Text.pack "forall" - in docSeq ([open] ++ tyVarDocLineList) + [ let + open = docLit $ Text.pack "forall" + in docSeq ([open]++tyVarDocLineList) , docPar - (docLit (Text.pack "forall")) - (docLines $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" - ] - ) + (docLit (Text.pack "forall")) + (docLines + $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ]) ] contextDoc = case cntxtDocs of [] -> docLit $ Text.pack "()" [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) , let - open = docCols - ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs + ] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) cntxtDoc + ] in docPar open $ docLines $ list ++ [close] ] docAlt -- :: forall a b c . (Foo a b c) => a b -> c [ docSeq [ if null bndrs - then docEmpty - else - let + then docEmpty + else let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) + in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) , docForceSingleline contextDoc , docLit $ Text.pack " => " , docForceSingleline typeDoc @@ -91,74 +111,75 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - forallDoc - (docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) $ contextDoc + forallDoc + ( docLines + [ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) + $ contextDoc + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] ] - , docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] - ] - ) + ) ] HsForAllTy _ hsf typ2 -> do let bndrs = getBinders hsf typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs docAlt -- forall x . x [ docSeq [ if null bndrs - then docEmpty - else - let + then docEmpty + else let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open] ++ tyVarDocLineList ++ [close]) + in docSeq ([open]++tyVarDocLineList++[close]) , docForceSingleline $ return $ typeDoc ] -- :: forall x -- . x , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ) -- :: forall -- (x :: *) -- . x , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> - docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ] + ) + ++[ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc ] + ] ) - ++ [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ] - ) ] HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do typeDoc <- docSharedWrapper layoutType typ1 @@ -169,27 +190,29 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) , let - open = docCols - ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) + $ head cntxtDocs + ] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) + $ cntxtDoc + ] in docPar open $ docLines $ list ++ [close] ] - let - maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id docAlt -- (Foo a b c) => a b -> c [ docSeq @@ -201,39 +224,37 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - (docForceSingleline contextDoc) - (docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) + (docForceSingleline contextDoc) + ( docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) ] HsFunTy _ _ typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id hasComments <- hasAnyCommentsBelow ltype - docAlt - $ [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 - ] - | not hasComments + docAlt $ + [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 ] - ++ [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 - ] - ) - ] + | not hasComments + ] ++ + [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) + $ maybeForceML typeDoc2 + ] + ) + ] HsParTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -243,28 +264,24 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack ")" ] , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack ")") + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack ")") ] HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let - gather - :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 - final -> (final, list) + let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 + final -> (final, list) let (typHead, typRest) = gather [typ2] typ1 docHead <- docSharedWrapper layoutType typHead docRest <- docSharedWrapper layoutType `mapM` typRest docAlt [ docSeq - $ docForceSingleline docHead - : (docRest >>= \d -> [docSeparator, docForceSingleline d]) + $ docForceSingleline docHead : (docRest >>= \d -> + [ docSeparator, docForceSingleline d ]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] HsAppTy _ typ1 typ2 -> do @@ -276,7 +293,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docSeparator , docForceSingleline typeDoc2 ] - , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) + , docPar + typeDoc1 + (docEnsureIndent BrIndentRegular typeDoc2) ] HsListTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 @@ -287,61 +306,51 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack "]" ] , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack "]") + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack "]") ] HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where - unboxed = if null typs - then error "brittany internal error: unboxed unit" - else unboxedL + unboxed = if null typs then error "brittany internal error: unboxed unit" + else unboxedL simple = if null typs then unitL else simpleL unitL = docLit $ Text.pack "()" simpleL = do docs <- docSharedWrapper layoutType `mapM` typs - let - end = docLit $ Text.pack ")" - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) + let end = docLit $ Text.pack ")" + lines = List.tail docs <&> \d -> + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt - [ docSeq - $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] + [ docSeq $ [docLit $ Text.pack "("] + ++ docWrapNodeRest ltype commaDocs + ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in - docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) + in docPar + (docAddBaseY (BrIndentSpecial 2) $ line1) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs - let - start = docParenHashLSep - end = docParenHashRSep + let start = docParenHashLSep + end = docParenHashRSep docAlt - [ docSeq - $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] + [ docSeq $ [start] + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) + ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] + lines = List.tail docs <&> \d -> + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ lines ++ [end]) @@ -410,18 +419,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack - ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + [ docWrapNodeRest ltype + $ docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") , docForceSingleline typeDoc1 ] , docPar - (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ] - ) + ( docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) + ) + (docCols ColTyOpPrefix + [ docWrapNodeRest ltype + $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ]) ] -- TODO: test KindSig HsKindSig _ typ1 kind1 -> do @@ -462,7 +473,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] else docPar typeDoc1 - (docCols + ( docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) kindDoc1 @@ -533,7 +544,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq - $ [docLit $ Text.pack "'["] + $ [docLit $ Text.pack "'["] ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"] , case splitFirstLast typDocs of @@ -558,23 +569,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse - specialCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) - ) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) ++ [docLit $ Text.pack " ]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] - lineN = docCols - ColList - [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> + docCols ColList [specialCommaSep, d] + lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype @@ -585,7 +592,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy NoSourceText _ -> error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> docLit $ Text.pack "_" + HsWildCardTy _ -> + docLit $ Text.pack "_" HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype HsStarTy _ isUnicode -> do @@ -598,12 +606,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of k <- docSharedWrapper layoutType kind docAlt [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar t (docSeq [docLit $ Text.pack "@", k]) + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar + t + (docSeq [docLit $ Text.pack "@", k ]) ] layoutTyVarBndrs diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs index b4785a5..29dc13c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -2,24 +2,28 @@ module Language.Haskell.Brittany.Internal.Obfuscation where -import Data.Char + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import System.Random + +import Data.Char +import System.Random + + obfuscate :: Text -> IO Text obfuscate input = do let predi x = isAlphaNum x || x `elem` "_'" let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let - exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x + let exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x let filtered = filter exceptionFilter idents mappings <- fmap Map.fromList $ filtered `forM` \x -> do r <- createAlias x @@ -71,14 +75,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] createAlias :: String -> IO String createAlias xs = go NoHint xs where - go _hint "" = pure "" - go hint (c : cr) = do + go _hint "" = pure "" + go hint (c : cr) = do c' <- case hint of VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr pure (c' : cr') diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs index 0790989..87a0c0a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,195 +1,346 @@ -module Language.Haskell.Brittany.Internal.Prelude - ( module E - ) where +module Language.Haskell.Brittany.Internal.Prelude ( module E ) where -import GHC.Hs.Extension as E (GhcPs) -import GHC.Types.Name.Reader as E (RdrName) -import Control.Applicative as E (Alternative(..), Applicative(..)) -import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) -import Control.Concurrent as E (forkIO, forkOS, threadDelay) -import Control.Concurrent.Chan as E (Chan) -import Control.Concurrent.MVar as E - (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) -import Control.Exception as E (assert, bracket, evaluate) -import Control.Monad as E - ( (<$!>) - , (<=<) - , (=<<) - , (>=>) - , Functor(..) - , Monad(..) - , MonadPlus(..) - , filterM - , forM - , forM_ - , forever - , guard - , join - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , mapM - , mapM_ - , replicateM - , replicateM_ - , sequence - , sequence_ - , unless - , void - , when - ) -import Control.Monad.Extra as E - (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) -import Control.Monad.IO.Class as E (MonadIO(..)) -import Control.Monad.ST as E (ST) -import Control.Monad.Trans.Class as E (lift) -import Control.Monad.Trans.Maybe as E (MaybeT(..)) -import Control.Monad.Trans.MultiRWS as E - (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) -import Data.Bifunctor as E (bimap) -import Data.Bool as E (Bool(..)) -import Data.Char as E (Char, chr, ord) -import Data.Data as E (toConstr) -import Data.Either as E (Either(..), either) -import Data.Foldable as E (asum, fold, foldl', foldr') -import Data.Function as E ((&), fix) -import Data.Functor as E (($>)) -import Data.Functor.Identity as E (Identity(..)) -import Data.IORef as E (IORef) -import Data.Int as E (Int) -import Data.List as E - ( all - , break - , drop - , dropWhile - , elem - , filter - , find - , intercalate - , intersperse - , isPrefixOf - , isSuffixOf - , iterate - , length - , mapAccumL - , mapAccumR - , maximum - , minimum - , notElem - , nub - , null - , partition - , repeat - , replicate - , sortBy - , sum - , take - , takeWhile - , transpose - , uncons - , unzip - , zip - , zip3 - , zipWith - ) -import Data.List.Extra as E (nubOrd, stripSuffix) -import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) -import Data.Map as E (Map) -import Data.Maybe as E - (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) -import Data.Monoid as E - ( All(..) - , Alt(..) - , Any(..) - , Endo(..) - , Monoid(..) - , Product(..) - , Sum(..) - , mconcat - ) -import Data.Ord as E (Down(..), Ordering(..), comparing) -import Data.Proxy as E (Proxy(..)) -import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) -import Data.Semigroup as E ((<>), Semigroup(..)) -import Data.Sequence as E (Seq) -import Data.Set as E (Set) -import Data.String as E (String) -import Data.Text as E (Text) -import Data.Tree as E (Tree(..)) -import Data.Tuple as E (swap) -import Data.Typeable as E (Typeable) -import Data.Version as E (showVersion) -import Data.Void as E (Void) -import Data.Word as E (Word, Word32) -import Debug.Trace as E - ( trace - , traceIO - , traceId - , traceM - , traceShow - , traceShowId - , traceShowM - , traceStack - ) -import Foreign.ForeignPtr as E (ForeignPtr) -import Foreign.Storable as E (Storable) -import GHC.Exts as E (Constraint) -import Prelude as E - ( ($) - , ($!) - , (&&) - , (++) - , (.) - , (<$>) - , Bounded(..) - , Double - , Enum(..) - , Eq(..) - , Float - , Floating(..) - , Foldable - , Fractional(..) - , Integer - , Integral(..) - , Num(..) - , Ord(..) - , RealFloat(..) - , RealFrac(..) - , Show(..) - , Traversable - , (^) - , and - , any - , const - , curry - , error - , flip - , foldl - , foldr - , foldr1 - , fromIntegral - , fst - , head - , id - , map - , not - , or - , otherwise - , print - , putStr - , putStrLn - , realToFrac - , reverse - , seq - , snd - , subtract - , traverse - , uncurry - , undefined - , (||) - ) -import System.IO as E (IO, hFlush, stdout) -import Text.Read as E (readMaybe) + +-- rather project-specific stuff: +--------------------------------- +import GHC.Hs.Extension as E ( GhcPs ) + +import GHC.Types.Name.Reader as E ( RdrName ) + + +-- more general: +---------------- + +import Data.Functor.Identity as E ( Identity(..) ) +import Control.Concurrent.Chan as E ( Chan ) +import Control.Concurrent.MVar as E ( MVar + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , takeMVar + , swapMVar + ) +import Data.Int as E ( Int ) +import Data.Word as E ( Word + , Word32 + ) +import Prelude as E ( Integer + , Float + , Double + , undefined + , Eq (..) + , Ord (..) + , Enum (..) + , Bounded (..) + , (<$>) + , (.) + , ($) + , ($!) + , Num (..) + , Integral (..) + , Fractional (..) + , Floating (..) + , RealFrac (..) + , RealFloat (..) + , fromIntegral + , error + , foldr + , foldl + , foldr1 + , id + , map + , subtract + , putStrLn + , putStr + , Show (..) + , print + , fst + , snd + , (++) + , not + , (&&) + , (||) + , curry + , uncurry + , flip + , const + , seq + , reverse + , otherwise + , traverse + , realToFrac + , or + , and + , head + , any + , (^) + , Foldable + , Traversable + ) +import Control.Monad.ST as E ( ST ) +import Data.Bool as E ( Bool(..) ) +import Data.Char as E ( Char + , ord + , chr + ) +import Data.Either as E ( Either(..) + , either + ) +import Data.IORef as E ( IORef ) +import Data.Maybe as E ( Maybe(..) + , fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + ) +import Data.Monoid as E ( Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + , Alt(..) + , mconcat + , Monoid (..) + ) +import Data.Ord as E ( Ordering(..) + , Down(..) + , comparing + ) +import Data.Ratio as E ( Ratio + , Rational + , (%) + , numerator + , denominator + ) +import Data.String as E ( String ) +import Data.Void as E ( Void ) +import System.IO as E ( IO + , hFlush + , stdout + ) +import Data.Proxy as E ( Proxy(..) ) +import Data.Sequence as E ( Seq ) + +import Data.Map as E ( Map ) +import Data.Set as E ( Set ) + +import Data.Text as E ( Text ) + +import Data.Function as E ( fix + , (&) + ) + +import Data.Foldable as E ( foldl' + , foldr' + , fold + , asum + ) + +import Data.List as E ( partition + , null + , elem + , notElem + , minimum + , maximum + , length + , all + , take + , drop + , find + , sum + , zip + , zip3 + , zipWith + , repeat + , replicate + , iterate + , nub + , filter + , intersperse + , intercalate + , isSuffixOf + , isPrefixOf + , dropWhile + , takeWhile + , unzip + , break + , transpose + , sortBy + , mapAccumL + , mapAccumR + , uncons + ) + +import Data.List.NonEmpty as E ( NonEmpty(..) + , nonEmpty + ) + +import Data.Tuple as E ( swap + ) + +import Text.Read as E ( readMaybe + ) + +import Control.Monad as E ( Functor (..) + , Monad (..) + , MonadPlus (..) + , mapM + , mapM_ + , forM + , forM_ + , sequence + , sequence_ + , (=<<) + , (>=>) + , (<=<) + , forever + , void + , join + , replicateM + , replicateM_ + , guard + , when + , unless + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , filterM + , (<$!>) + ) + +import Control.Applicative as E ( Applicative (..) + , Alternative (..) + ) + +import Foreign.Storable as E ( Storable ) +import GHC.Exts as E ( Constraint ) + +import Control.Concurrent as E ( threadDelay + , forkIO + , forkOS + ) + +import Control.Exception as E ( evaluate + , bracket + , assert + ) + +import Debug.Trace as E ( trace + , traceId + , traceShowId + , traceShow + , traceStack + , traceShowId + , traceIO + , traceM + , traceShowM + ) + +import Foreign.ForeignPtr as E ( ForeignPtr + ) + +import Data.Bifunctor as E ( bimap ) +import Data.Functor as E ( ($>) ) +import Data.Semigroup as E ( (<>) + , Semigroup(..) + ) + +import Data.Typeable as E ( Typeable + ) + +import Control.Arrow as E ( first + , second + , (***) + , (&&&) + , (>>>) + , (<<<) + ) + +import Data.Version as E ( showVersion + ) + +import Data.List.Extra as E ( nubOrd + , stripSuffix + ) +import Control.Monad.Extra as E ( whenM + , unlessM + , ifM + , notM + , orM + , andM + , anyM + , allM + ) + +import Data.Tree as E ( Tree(..) + ) + +import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) + -- , MultiRWSTNull + -- , MultiRWS + -- , + MonadMultiReader(..) + , MonadMultiWriter(..) + , MonadMultiState(..) + , mGet + -- , runMultiRWST + -- , runMultiRWSTASW + -- , runMultiRWSTW + -- , runMultiRWSTAW + -- , runMultiRWSTSW + -- , runMultiRWSTNil + -- , runMultiRWSTNil_ + -- , withMultiReader + -- , withMultiReader_ + -- , withMultiReaders + -- , withMultiReaders_ + -- , withMultiWriter + -- , withMultiWriterAW + -- , withMultiWriterWA + -- , withMultiWriterW + -- , withMultiWriters + -- , withMultiWritersAW + -- , withMultiWritersWA + -- , withMultiWritersW + -- , withMultiState + -- , withMultiStateAS + -- , withMultiStateSA + -- , withMultiStateA + -- , withMultiStateS + -- , withMultiState_ + -- , withMultiStates + -- , withMultiStatesAS + -- , withMultiStatesSA + -- , withMultiStatesA + -- , withMultiStatesS + -- , withMultiStates_ + -- , inflateReader + -- , inflateMultiReader + -- , inflateWriter + -- , inflateMultiWriter + -- , inflateState + -- , inflateMultiState + -- , mapMultiRWST + -- , mGetRawR + -- , mGetRawW + -- , mGetRawS + -- , mPutRawR + -- , mPutRawW + -- , mPutRawS + ) + +import Control.Monad.IO.Class as E ( MonadIO (..) + ) + +import Control.Monad.Trans.Class as E ( lift + ) +import Control.Monad.Trans.Maybe as E ( MaybeT (..) + ) + +import Data.Data as E ( toConstr + ) diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs index fcfe303..cfaed43 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -1,15 +1,21 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Brittany.Internal.PreludeUtils where -import Control.Applicative -import Control.DeepSeq (NFData, force) -import Control.Exception.Base (evaluate) -import Control.Monad + + +import Prelude import qualified Data.Strict.Maybe as Strict import Debug.Trace -import Prelude +import Control.Monad import System.IO +import Control.DeepSeq ( NFData, force ) +import Control.Exception.Base ( evaluate ) + +import Control.Applicative + + + instance Applicative Strict.Maybe where pure = Strict.Just Strict.Just f <*> Strict.Just x = Strict.Just (f x) @@ -24,12 +30,12 @@ instance Alternative Strict.Maybe where x <|> Strict.Nothing = x _ <|> x = x -traceFunctionWith - :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) traceFunctionWith name s1 s2 f x = trace traceStr y where y = f x - traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y + traceStr = + name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y (<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) = flip (<$!>) @@ -45,10 +51,10 @@ printErr = putStrErrLn . show errorIf :: Bool -> a -> a errorIf False = id -errorIf True = error "errorIf" +errorIf True = error "errorIf" errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id +errorIfNote Nothing = id errorIfNote (Just x) = error x (<&>) :: Functor f => f a -> (a -> b) -> f b diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 1fd3eb7..ca79995 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -9,18 +9,25 @@ module Language.Haskell.Brittany.Internal.Transformations.Alt where -import qualified Control.Monad.Memo as Memo + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.HList.ContainsType import qualified Data.List.Extra import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Data.HList.ContainsType + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Control.Monad.Memo as Memo + + data AltCurPos = AltCurPos { _acp_line :: Int -- chars in the current line @@ -28,7 +35,7 @@ data AltCurPos = AltCurPos , _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_forceMLFlag :: AltLineModeState } - deriving Show + deriving (Show) data AltLineModeState = AltLineModeStateNone @@ -39,19 +46,17 @@ data AltLineModeState deriving (Show) altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = - AltLineModeStateContradiction +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone -altLineModeDecay (AltLineModeStateForceML False) = - AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of @@ -76,7 +81,7 @@ transformAlts = . Memo.startEvalMemoT . fmap unwrapBriDocNumbered . rec - where + where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) -- transWrap :: BriDoc -> BriDocNumbered @@ -114,246 +119,224 @@ transformAlts = - rec - :: BriDocNumbered - -> Memo.MemoT - Int - [VerticalSpacing] - (MultiRWSS.MultiRWS r w (AltCurPos ': s)) - BriDocNumbered - rec bdX@(brDcId, brDc) = do - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let - indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- - mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let - lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk - let - options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - (hasSpace1 lconf acp vs && lineCheck vs, bd) - ) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust - (\(_i :: Int, (b, x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ] - ) - $ zip [1 ..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let - lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk - let - options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) - ) - let - checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered + rec bdX@(brDcId, brDc) = do + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> + reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> + reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd mSet $ acp - { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp + { _acp_indent = ind + , _acp_indentPrep = 0 } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do + sameLine' <- rec sameLine + mModify $ \acp' -> acp' + { _acp_line = ind + , _acp_indent = ind + } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( hasSpace1 lconf acp vs && lineCheck vs, bd)) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ]) + $ zip [1..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let lineCheck (VerticalSpacing _ p _) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( any (hasSpace2 lconf acp) vs + && any lineCheck vs, bd)) + let checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l:lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp + { _acp_line = ind + , _acp_indent = ind + } + rec x + return $ reWrap $ BDFLines (l':lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing _ bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do acp <- mGet - mSet $ acp - { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp - } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l : lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } - rec x - return $ reWrap $ BDFLines (l' : lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> - reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess - $ "transformAlts: BDFDEBUG " - ++ s - ++ " (node-id=" - ++ show brDcId - ++ "): acp=" - ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do - acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 - :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line - + sameLine - <= confUnpack (_lconfig_cols lconf) - && indent - + indentPrep - + par - <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) getSpacing :: forall m @@ -370,11 +353,10 @@ getSpacing !bridoc = rec bridoc -- BDWrapAnnKey _annKey bd -> rec bd BDFEmpty -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> return $ LineModeValid $ VerticalSpacing - (Text.length t) - VerticalSpacingParNone - False - BDFSeq list -> sumVs <$> rec `mapM` list + BDFLit t -> + return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False + BDFSeq list -> + sumVs <$> rec `mapM` list BDFCols _sig list -> sumVs <$> rec `mapM` list BDFSeparator -> return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False @@ -382,28 +364,22 @@ getSpacing !bridoc = rec bridoc mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> - VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> - VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j } BDFBaseYPushCur bd -> do @@ -414,13 +390,11 @@ getSpacing !bridoc = rec bridoc -- the reason is that we really want to _keep_ it Just if it is -- just so we properly communicate the is-multiline fact. -- An alternative would be setting to (Just 0). - { _vs_sameLine = max - (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i - ) + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) , _vs_paragraph = VerticalSpacingParSome 0 } BDFBaseYPop bd -> rec bd @@ -434,104 +408,86 @@ getSpacing !bridoc = rec bridoc | VerticalSpacing lsp mPsp _ <- mVs , indSp <- mIndSp , lineMax <- getMaxVS $ mIndSp - , let - pspResult = case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp lineMax - , let - parFlagResult = - mPsp - == VerticalSpacingParNone - && _vs_paragraph indSp - == VerticalSpacingParNone - && _vs_parFlag indSp + , let pspResult = case mPsp of + VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax + , let parFlagResult = mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp ] BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt : _) -> rec alt - BDFForceMultiline bd -> do + BDFAlt (alt:_) -> rec alt + BDFForceMultiline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> LineModeInvalid - _ -> mVs + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> mVs - _ -> LineModeInvalid + _ -> LineModeInvalid BDFForwardLineMode bd -> rec bd BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_ : _) -> do + BDFLines [] -> return + $ LineModeValid + $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_:_) -> do lSps <- rec `mapM` ls - let (mVs : _) = lSps -- separated into let to avoid MonadFail - return - $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] + let (mVs:_) = lSps -- separated into let to avoid MonadFail + return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] BDFEnsureIndent indent bd -> do mVs <- rec bd - let - addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config - BrIndentSpecial i -> i + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf BDFNonBottomSpacing b bd -> do mVs <- rec bd - return $ mVs <|> LineModeValid - (VerticalSpacing - 0 - (if b - then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) + return + $ mVs + <|> LineModeValid + (VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } BDFForceParSpacing bd -> do mVs <- rec bd - return - $ [ vs - | vs <- mVs - , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone - ] + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] BDFDebug s bd -> do r <- rec bd - tellDebugMess - $ "getSpacing: BDFDebug " - ++ show s - ++ " (node-id=" - ++ show brDcId - ++ "): mVs=" - ++ show r + tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r return r return result - maxVs - :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs = foldl' - (liftM2 - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of + (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing (max x1 y1) (case (x2, y2) of (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> @@ -541,14 +497,9 @@ getSpacing !bridoc = rec bridoc (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> VerticalSpacingParAlways $ max i j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y - ) - False - ) - ) + VerticalSpacingParSome $ max x y) False)) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs - :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing sumVs sps = foldl' (liftM2 go) initial sps where go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing @@ -557,19 +508,18 @@ getSpacing !bridoc = rec bridoc (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j + VerticalSpacingParAlways $ i+j (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j + VerticalSpacingParAlways $ i+j (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j + VerticalSpacingParAlways $ i+j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) + VerticalSpacingParSome $ x + y) x3 singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False + singleline _ = False isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False + isPar _ = False parFlag = case sps of [] -> True _ -> all singleline (List.init sps) && isPar (List.last sps) @@ -589,395 +539,374 @@ getSpacings -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where + where -- when we do `take K . filter someCondition` on a list of spacings, we -- need to first (also) limit the size of the input list, otherwise a -- _large_ input with a similarly _large_ prefix not passing our filtering -- process could lead to exponential runtime behaviour. -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3 * limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec - :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let - hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let - specialCompare vs1 vs2 = - if ((_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let - allowHangingQuasiQuotes = - config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = - take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return - $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> - VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> - VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max - (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i - ) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] - return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp - ) - (mPsp - == VerticalSpacingParNone - && _vs_paragraph indSp - == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return - $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1] -> - VerticalSpacing (Text.length t1) VerticalSpacingParNone False - (t1 : _) -> VerticalSpacing - (Text.length t1) - (VerticalSpacingParAlways 0) - True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_ : _) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let - worbled = fmap reverse $ sequence $ reverse $ lSpss - sumF lSps@(lSp1 : _) = - VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False - sumF [] = - error - $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let - addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then - [ VerticalSpacing - 0 - (if b - then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3*limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let hasOkColCount (VerticalSpacing lsp psp _) = + lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let specialCompare vs1 vs2 = + if ( (_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let allowHangingQuasiQuotes = + config + & _conf_layout + & _lconfig_allowHangingQuasiQuotes + & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . specialNub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> + fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFSeparator -> + return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return - $ [ vs - | vs <- mVs - , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone - ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess - $ "getSpacings: BDFDebug " - ++ show s - ++ " (node-id=" - ++ show brDcId - ++ "): vs=" - ++ show (take 9 r) - return r - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y - ) - False - ) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit + $ [ (x,y) + | x<-mVss + , y<-indSps + ] + return $ mVsIndSp <&> + \(VerticalSpacing lsp mPsp _, indSp) -> + VerticalSpacing + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp) + ( mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> + return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1 ] -> VerticalSpacing + (Text.length t1) + VerticalSpacingParNone + False + (t1 : _) -> VerticalSpacing + (Text.length t1) + (VerticalSpacingParAlways 0) + True + | allowHangingQuasiQuotes + ] + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_:_) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- map filterAndLimit <$> rec `mapM` ls + let worbled = fmap reverse + $ sequence + $ reverse + $ lSpss + sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + sumF [] = error $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. + mVs <- rec bd + return $ if null mVs + then [VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] + else mVs <&> \vs -> vs + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) + return r + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) + False) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i fixIndentationForMultiple :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int fixIndentationForMultiple acp indent = do indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let - indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i + let indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i -- for IndentPolicyMultiple, we restrict the amount of added -- indentation in such a manner that we end up on a multiple of the -- base indentation. indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack pure $ if indPolicy == IndentPolicyMultiple then - let - indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 + let indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 5229134..89a2c6f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -3,10 +3,16 @@ module Language.Haskell.Brittany.Internal.Transformations.Columns where -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List + + import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + transformSimplifyColumns :: BriDoc -> BriDoc transformSimplifyColumns = Uniplate.rewrite $ \case @@ -14,150 +20,118 @@ transformSimplifyColumns = Uniplate.rewrite $ \case -- BDWrapAnnKey annKey $ transformSimplify bd BDEmpty -> Nothing BDLit{} -> Nothing - BDSeq list - | any - (\case - BDSeq{} -> True - BDEmpty{} -> True - _ -> False - ) - list - -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_ : _) : rest) - | all - (\case - BDSeparator -> True - _ -> False - ) - rest - -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)]) - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDSeq list | any (\case BDSeq{} -> True + BDEmpty{} -> True + _ -> False) list -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) + | all (\case BDSeparator -> True; _ -> False) rest -> + Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) + BDLines lines | any (\case BDLines{} -> True + BDEmpty{} -> True + _ -> False) lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l x -> [x] -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) -- post floating in BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] -- ensureIndent float-in -- not sure if the following rule is necessary; tests currently are -- unaffected. -- BDEnsureIndent indent (BDLines lines) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines -- matching col special transformation - BDCols sig1 cols1@(_ : _) - | BDLines lines@(_ : _ : _) <- List.last cols1 + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 , BDCols sig2 cols2 <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_ : _) - | BDLines lines@(_ : _ : _) <- List.last cols1 + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) - | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) + | sig1==sig2 -> + Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just - $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) - | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just - $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- | sig1==sig2 -> -- Just $ BDPar -- ind1 -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols - | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 - -> Just - $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] - BDCols sig1 cols - | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 - $ List.init cols - ++ [BDPar ind line (BDLines $ List.init lines)] + BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 (List.init cols ++ [line]) , BDCols sig2 cols2 ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing + BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] + , BDCols sig2 cols2 + ] + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing BDForceSingleline{} -> Nothing BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing + BDExternal{} -> Nothing + BDPlain{} -> Nothing + BDLines{} -> Nothing BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing + BDDebug{} -> Nothing BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index c320dbf..0231306 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -3,20 +3,25 @@ module Language.Haskell.Brittany.Internal.Transformations.Floating where -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + -- note that this is not total, and cannot be with that exact signature. mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = - BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" transformSimplifyFloating :: BriDoc -> BriDoc @@ -26,192 +31,169 @@ transformSimplifyFloating = stepBO .> stepFull -- better complexity. -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just - $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> Just x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> Just $ x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + BDAddBaseY BrIndentNone x -> + Just x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> + Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + BDAddBaseY BrIndentNone x -> + Just $ x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 9596e5b..7f7d7e5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -3,10 +3,16 @@ module Language.Haskell.Brittany.Internal.Transformations.Indent where -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List + + import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + -- prepare layouting by translating BDPar's, replacing them with Indents and -- floating those in. This gives a more clear picture of what exactly is @@ -25,17 +31,15 @@ transformSimplifyIndent = Uniplate.rewrite $ \case -- [ BDAddBaseY ind x -- , BDEnsureIndent ind indented -- ] - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l - x -> [x] + x -> [x] BDLines [l] -> Just l BDAddBaseY i (BDAnnotationPrior k x) -> Just $ BDAnnotationPrior k (BDAddBaseY i x) @@ -49,4 +53,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY _ lit@BDLit{} -> Just lit - _ -> Nothing + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 7fb4aff..305ee08 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -3,9 +3,14 @@ module Language.Haskell.Brittany.Internal.Transformations.Par where + + import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Types + + transformSimplifyPar :: BriDoc -> BriDoc transformSimplifyPar = transformUp $ \case @@ -19,28 +24,25 @@ transformSimplifyPar = transformUp $ \case BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs where go = (=<<) $ \case BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x -- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- BDPar BrIndentNone line indented -> -- Just $ BDLines [line, indented] BDEnsureIndent BrIndentNone x -> x - x -> x + x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 41d809b..76b7735 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -12,47 +12,52 @@ module Language.Haskell.Brittany.Internal.Types where + + +import Language.Haskell.Brittany.Internal.Prelude import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data -import Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Kind as Kind import qualified Data.Strict.Maybe as Strict -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint (AnnKey) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types (Anns) import qualified Safe +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan ) + +import Language.Haskell.GHC.ExactPrint ( AnnKey ) +import Language.Haskell.GHC.ExactPrint.Types ( Anns ) + +import Language.Haskell.Brittany.Internal.Config.Types + +import Data.Generics.Uniplate.Direct as Uniplate + +import qualified Data.Kind as Kind + + + data PerItemConfig = PerItemConfig { _icd_perBinding :: Map String (CConfig Maybe) , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) } deriving Data.Data.Data -type PPM - = MultiRWSS.MultiRWS - '[ Map ExactPrint.AnnKey ExactPrint.Anns - , PerItemConfig - , Config - , ExactPrint.Anns - ] - '[Text.Builder.Builder , [BrittanyError] , Seq String] - '[] +type PPM = MultiRWSS.MultiRWS + '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] -type PPMLocal - = MultiRWSS.MultiRWS - '[Config , ExactPrint.Anns] - '[Text.Builder.Builder , [BrittanyError] , Seq String] - '[] +type PPMLocal = MultiRWSS.MultiRWS + '[Config, ExactPrint.Anns] + '[Text.Builder.Builder, [BrittanyError], Seq String] + '[] newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) data LayoutState = LayoutState - { _lstate_baseYs :: [Int] + { _lstate_baseYs :: [Int] -- ^ stack of number of current indentation columns -- (not number of indentations). , _lstate_curYOrAddNewline :: Either Int Int @@ -60,7 +65,7 @@ data LayoutState = LayoutState -- 1) number of chars in the current line. -- 2) number of newlines to be inserted before inserting any -- non-space elements. - , _lstate_indLevels :: [Int] + , _lstate_indLevels :: [Int] -- ^ stack of current indentation levels. set for -- any layout-affected elements such as -- let/do/case/where elements. @@ -73,14 +78,14 @@ data LayoutState = LayoutState -- on the first indented element have an -- annotation offset relative to the last -- non-indented element, which is confusing. - , _lstate_comments :: Anns - , _lstate_commentCol :: Maybe Int -- this communicates two things: + , _lstate_comments :: Anns + , _lstate_commentCol :: Maybe Int -- this communicates two things: -- firstly, that cursor is currently -- at the end of a comment (so needs -- newline before any actual content). -- secondly, the column at which -- insertion of comments started. - , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone + , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone -- writes (any non-spaces) in the -- current line. -- , _lstate_isNewline :: NewLineState @@ -110,21 +115,14 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels instance Show LayoutState where show state = "LayoutState" - ++ "{baseYs=" - ++ show (_lstate_baseYs state) - ++ ",curYOrAddNewline=" - ++ show (_lstate_curYOrAddNewline state) - ++ ",indLevels=" - ++ show (_lstate_indLevels state) - ++ ",indLevelLinger=" - ++ show (_lstate_indLevelLinger state) - ++ ",commentCol=" - ++ show (_lstate_commentCol state) - ++ ",addSepSpace=" - ++ show (_lstate_addSepSpace state) - ++ ",commentNewlines=" - ++ show (_lstate_commentNewlines state) - ++ "}" + ++ "{baseYs=" ++ show (_lstate_baseYs state) + ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) + ++ ",indLevels=" ++ show (_lstate_indLevels state) + ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) + ++ ",commentCol=" ++ show (_lstate_commentCol state) + ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) + ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- -- newline, really. by special-casing @@ -225,16 +223,14 @@ data BrIndent = BrIndentNone | BrIndentSpecial Int deriving (Eq, Ord, Data.Data.Data, Show) -type ToBriDocM - = MultiRWSS.MultiRWS - '[Config , Anns] -- reader - '[[BrittanyError] , Seq String] -- writer - '[NodeAllocIndex] -- state +type ToBriDocM = MultiRWSS.MultiRWS + '[Config, Anns] -- reader + '[[BrittanyError], Seq String] -- writer + '[NodeAllocIndex] -- state -type ToBriDoc (sym :: Kind.Type -> Kind.Type) - = Located (sym GhcPs) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c +type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = Located sym -> ToBriDocM c data DocMultiLine = MultiLineNo @@ -342,21 +338,21 @@ type BriDocFInt = BriDocF ((,) Int) type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = @@ -365,84 +361,83 @@ instance Uniplate.Uniplate BriDoc where plate BDAnnotationRest |- annKey |* bd uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd) = plate BDDebug |- s |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int -- TODO: rename to "dropLabels" ? unwrapBriDocNumbered :: BriDocNumbered -> BriDoc unwrapBriDocNumbered tpl = case snd tpl of - BDFEmpty -> BDEmpty - BDFLit t -> BDLit t - BDFSeq list -> BDSeq $ rec <$> list - BDFCols sig list -> BDCols sig $ rec <$> list - BDFSeparator -> BDSeparator - BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDFBaseYPop bd -> BDBaseYPop $ rec bd - BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDFPar ind line indented -> BDPar ind (rec line) (rec indented) - BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDFForwardLineMode bd -> BDForwardLineMode $ rec bd - BDFExternal k ks c t -> BDExternal k ks c t - BDFPlain t -> BDPlain t + BDFEmpty -> BDEmpty + BDFLit t -> BDLit t + BDFSeq list -> BDSeq $ rec <$> list + BDFCols sig list -> BDCols sig $ rec <$> list + BDFSeparator -> BDSeparator + BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDFBaseYPop bd -> BDBaseYPop $ rec bd + BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDFPar ind line indented -> BDPar ind (rec line) (rec indented) + BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDFForwardLineMode bd -> BDForwardLineMode $ rec bd + BDFExternal k ks c t -> BDExternal k ks c t + BDFPlain t -> BDPlain t BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd - BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd - BDFLines lines -> BDLines $ rec <$> lines - BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd + BDFLines lines -> BDLines $ rec <$> lines + BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False -isNotEmpty _ = True +isNotEmpty _ = True -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd - BDPar _ind line indented -> - briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDPlain{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd + BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented + BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDPlain{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd @@ -461,19 +456,18 @@ data VerticalSpacingPar -- product like (Normal|Always, None|Some Int). deriving (Eq, Show) -data VerticalSpacing = VerticalSpacing - { _vs_sameLine :: !Int - , _vs_paragraph :: !VerticalSpacingPar - , _vs_parFlag :: !Bool - } +data VerticalSpacing + = VerticalSpacing + { _vs_sameLine :: !Int + , _vs_paragraph :: !VerticalSpacingPar + , _vs_parFlag :: !Bool + } deriving (Eq, Show) newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) deriving (Functor, Applicative, Monad, Show, Alternative) -pattern LineModeValid :: forall t . t -> LineModeValidity t -pattern LineModeValid x = - LineModeValidity (Strict.Just x) :: LineModeValidity t -pattern LineModeInvalid :: forall t . LineModeValidity t -pattern LineModeInvalid = - LineModeValidity Strict.Nothing :: LineModeValidity t +pattern LineModeValid :: forall t. t -> LineModeValidity t +pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t +pattern LineModeInvalid :: forall t. LineModeValidity t +pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index a52caa4..a12f7ea 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -7,29 +7,40 @@ module Language.Haskell.Brittany.Internal.Utils where -import qualified Data.ByteString as B -import qualified Data.Coerce -import Data.Data -import Data.Generics.Aliases -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import DataTreePrint -import qualified GHC.Data.FastString as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Hs.Extension as HsExtension -import qualified GHC.OldList as List -import GHC.Types.Name.Occurrence as OccName (occNameString) -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Utils.Outputable as GHC -import Language.Haskell.Brittany.Internal.Config.Types + + import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types +import qualified Data.Coerce +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence as Seq +import qualified GHC.OldList as List + import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils + +import Data.Data +import Data.Generics.Aliases + import qualified Text.PrettyPrint as PP +import qualified GHC.Utils.Outputable as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Types.SrcLoc as GHC +import GHC.Types.Name.Occurrence as OccName ( occNameString ) +import qualified Data.ByteString as B + +import DataTreePrint + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified GHC.Hs.Extension as HsExtension + + + parDoc :: String -> PP.Doc parDoc = PP.fsep . fmap PP.text . List.words @@ -44,8 +55,7 @@ showOutputable :: (GHC.Outputable a) => a -> String showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = - Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y +fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity x y = @@ -60,26 +70,24 @@ instance (Num a, Ord a) => Semigroup (Max a) where (<>) = Data.Coerce.coerce (max :: a -> a -> a) instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 + mempty = Max 0 mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data -instance Show ShowIsId where - show (ShowIsId x) = x +instance Show ShowIsId where show (ShowIsId x) = x -data A x = A ShowIsId x - deriving Data +data A x = A ShowIsId x deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -87,22 +95,18 @@ customLayouterF anns layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = - simpleLayouter + srcSpan ss = simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" - ++ showOutputable ss - ++ "}" + $ "{" ++ showOutputable ss ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where @@ -114,12 +118,12 @@ customLayouterF anns layoutF = customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -127,15 +131,14 @@ customLayouterNoAnnsF layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter @@ -199,11 +202,12 @@ traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () -tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () +tellDebugMess :: MonadMultiWriter + (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s -tellDebugMessShow - :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () +tellDebugMessShow :: forall a m . (MonadMultiWriter + (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. @@ -218,28 +222,29 @@ briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = - printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) +annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1 : aR) = case fn a1 of - Left b -> (b : bs, cs) +breakEither _ [] = ([], []) +breakEither fn (a1:aR) = case fn a1 of + Left b -> (b : bs, cs) Right c -> (bs, c : cs) - where (bs, cs) = breakEither fn aR + where + (bs, cs) = breakEither fn aR spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) - where (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) +spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) + where + (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) data FirstLastView a = FirstLastEmpty @@ -249,7 +254,7 @@ data FirstLastView a splitFirstLast :: [a] -> FirstLastView a splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) +splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) -- TODO: move to uniplate upstream? -- aka `transform` @@ -268,7 +273,7 @@ lines' :: String -> [String] lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] - (s1, (_ : r)) -> s1 : lines' r + (s1, (_:r)) -> s1 : lines' r absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index 7f22f11..87ebe66 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -4,41 +4,58 @@ module Language.Haskell.Brittany.Main where -import Control.Monad (zipWithM) + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils import qualified Control.Monad.Trans.Except as ExceptT -import Data.CZipWith import qualified Data.Either import qualified Data.List.Extra -import qualified Data.Monoid import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy as TextL -import DataTreePrint -import GHC (GenLocated(L)) -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List -import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Obfuscation -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Paths_brittany -import qualified System.Directory as Directory -import qualified System.Exit -import qualified System.FilePath.Posix as FilePath import qualified System.IO -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Text.PrettyPrint as PP -import Text.Read (Read(..)) -import UI.Butcher.Monadic + +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Data.Monoid + +import GHC ( GenLocated(L) ) +import GHC.Utils.Outputable ( Outputable(..) + , showSDocUnsafe + ) + +import Text.Read ( Read(..) ) +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec + +import Control.Monad ( zipWithM ) +import Data.CZipWith + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Obfuscation + +import qualified Text.PrettyPrint as PP + +import DataTreePrint +import UI.Butcher.Monadic + +import qualified System.Exit +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Paths_brittany + + data WriteMode = Display | Inplace @@ -93,7 +110,7 @@ helpDoc = PP.vcat $ List.intersperse ] , parDoc $ "See https://github.com/lspitzner/brittany" , parDoc - $ "Please report bugs at" + $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" ] @@ -130,16 +147,15 @@ mainCmdParser helpDesc = do addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams - "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser + configPaths <- addFlagStringParams "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] @@ -165,7 +181,7 @@ mainCmdParser helpDesc = do "" ["write-mode"] "(display|inplace)" - (flagHelp + ( flagHelp (PP.vcat [ PP.text "display: output for any input(s) goes to stdout" , PP.text "inplace: override respective input file (without backup!)" @@ -195,13 +211,11 @@ mainCmdParser helpDesc = do $ ppHelpShallow helpDesc System.Exit.exitSuccess - let - inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let - outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths + let inputPaths = + if null inputParams then [Nothing] else map Just inputParams + let outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths configsToLoad <- liftIO $ if null configPaths then @@ -216,15 +230,14 @@ mainCmdParser helpDesc = do ) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x + Just x -> return x when (config & _conf_debug & _dconf_dump_config & confUnpack) $ trace (showConfigYaml config) $ return () - results <- zipWithM - (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths + results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths if checkMode then when (Changes `elem` (Data.Either.rights results)) @@ -253,65 +266,58 @@ coreIO -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = ExceptT.runExceptT $ do - let - putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let ghcOptions = config & _conf_forward & _options_ghc & runIdentity -- there is a good of code duplication between the following code and the -- `pureModuleTransform` function. Unfortunately, there are also a good -- amount of slight differences: This module is a bit more verbose, and -- it tries to use the full-blown `parseModule` function which supports -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack -- the flag will do the following: insert a marker string -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- "#include" before processing (parsing) input; and remove that marker -- string from the transformation output. -- The flag is intentionally misspelled to prevent clashing with -- inline-config stuff. - let - hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let - exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + let hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic - let - hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let - hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id inputString <- liftIO System.IO.getContents - parseRes <- liftIO $ parseModuleFromString - ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) + parseRes <- liftIO $ parseModuleFromString ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) return (parseRes, Text.pack inputString) Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc + parseRes <- parseModule ghcOptions p cppCheckFunc inputText <- Text.IO.readFile p -- The above means we read the file twice, but the -- GHC API does not really expose the source it @@ -340,12 +346,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = pure c let moduleConf = cZipWith fromOptionIdentity config inlineConf when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let - val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () - let - disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack + let disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack (errsWarns, outSText, hasChanges) <- do if | disableFormatting -> do @@ -354,52 +358,46 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let r = Text.pack $ ExactPrint.exactPrint parsedSource anns pure ([], r, r /= originalContents) | otherwise -> do - let - omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck - moduleConf - perItemConf - anns - parsedSource - let - hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let - out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - else outRaw + else liftIO $ pPrintModuleAndCheck moduleConf + perItemConf + anns + parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out pure $ (ews, out', out' /= originalContents) - let - customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 unless (null errsWarns) $ do - let - groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns + let groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns groupedErrsWarns `forM_` \case (ErrorOutputCheck{} : _) -> do putErrorLn - $ "ERROR: brittany pretty printer" + $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str @@ -408,10 +406,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ "WARNING: encountered unknown syntactical constructs:" uns `forM_` \case ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe - (ppr loc) + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) when - (config + ( config & _conf_debug & _dconf_dump_ast_unknown & confUnpack @@ -425,17 +422,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = putErrorLn $ "WARNINGS:" warns `forM_` \case LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" unused@(ErrorUnusedComment{} : _) -> do putErrorLn - $ "Error: detected unprocessed comments." + $ "Error: detected unprocessed comments." ++ " The transformation output will most likely" ++ " not contain some of the comments" ++ " present in the input haskell source file." putErrorLn $ "Affected are the following comments:" unused `forM_` \case ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" (ErrorMacroConfig err input : _) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err @@ -446,8 +443,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let hasErrors = if config & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) outputOnErrs = config & _conf_errorHandling @@ -462,11 +459,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ addTraceSep (_conf_debug config) $ case outputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let - isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges + Just p -> liftIO $ do + let isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText when (checkMode && hasChanges) $ case inputPathM of @@ -478,15 +474,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = where addTraceSep conf = if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] then trace "----" else id diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index a39eecf..774088f 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -2,24 +2,35 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE ScopedTypeVariables #-} -import Data.Coerce (coerce) -import Data.List (groupBy) +import Language.Haskell.Brittany.Internal.Prelude import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified System.Directory -import System.FilePath (()) -import System.Timeout (timeout) -import Test.Hspec -import qualified Text.Parsec as Parsec -import Text.Parsec.Text (Parser) + +import Test.Hspec + +import qualified Text.Parsec as Parsec +import Text.Parsec.Text ( Parser ) + +import Data.List ( groupBy ) + +import Language.Haskell.Brittany.Internal + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config + +import Data.Coerce ( coerce ) + +import qualified Data.Text.IO as Text.IO +import System.FilePath ( () ) + +import System.Timeout ( timeout ) + + + +import Language.Haskell.Brittany.Internal.PreludeUtils hush :: Either a b -> Maybe b hush = either (const Nothing) Just @@ -29,32 +40,32 @@ hush = either (const Nothing) Just asymptoticPerfTest :: Spec asymptoticPerfTest = do it "10 do statements" - $ roundTripEqualWithTimeout 1500000 - $ (Text.pack "func = do\n") + $ roundTripEqualWithTimeout 1500000 + $ (Text.pack "func = do\n") <> Text.replicate 10 (Text.pack " statement\n") it "10 do nestings" - $ roundTripEqualWithTimeout 4000000 - $ (Text.pack "func = ") + $ roundTripEqualWithTimeout 4000000 + $ (Text.pack "func = ") <> mconcat - ([1 .. 10] <&> \(i :: Int) -> - (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") + ( [1 .. 10] + <&> \(i :: Int) -> + (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") ) <> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n" <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" it "10 AppOps" - $ roundTripEqualWithTimeout 1000000 - $ (Text.pack "func = expr") + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = expr") <> Text.replicate 10 (Text.pack "\n . expr") --TODO roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust) + timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) where - action = fmap - (fmap PPTextWrapper) - (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + action = fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) data InputLine @@ -74,11 +85,10 @@ data TestCase = TestCase main :: IO () main = do files <- System.Directory.listDirectory "data/" - let - blts = - List.sort - $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt" `isSuffixOf`) files + let blts = + List.sort + $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) + $ filter (".blt" `isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("data" blt) let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt" @@ -89,17 +99,15 @@ main = do it "gives properly formatted result for valid input" $ do let input = Text.pack $ unlines - [ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]" - ] - let - expected = Text.pack $ unlines - [ "func =" - , " [ 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " , 00000000000000000000000" - , " ]" - ] + ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] + let expected = Text.pack $ unlines + [ "func =" + , " [ 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " ]" + ] output <- liftIO $ parsePrintModule staticDefaultConfig input hush output `shouldBe` Just expected groups `forM_` \(groupname, tests) -> do @@ -146,33 +154,30 @@ main = do testProcessor = \case HeaderLine n : rest -> let normalLines = Data.Maybe.mapMaybe extractNormal rest - in - TestCase - { testName = n - , isPending = any isPendingLine rest - , content = Text.unlines normalLines - } + in TestCase + { testName = n + , isPending = any isPendingLine rest + , content = Text.unlines normalLines + } l -> - error - $ "first non-empty line must start with #test footest\n" - ++ show l + error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l - extractNormal _ = Nothing + extractNormal _ = Nothing isPendingLine PendingLine{} = True - isPendingLine _ = False + isPendingLine _ = False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#group" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" + | _ <- Parsec.try $ Parsec.string "#group" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof + , _ <- Parsec.eof ] , [ HeaderLine $ Text.pack name - | _ <- Parsec.try $ Parsec.string "#test" - , _ <- Parsec.many1 $ Parsec.oneOf " \t" + | _ <- Parsec.try $ Parsec.string "#test" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" - , _ <- Parsec.eof + , _ <- Parsec.eof ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" @@ -192,17 +197,17 @@ main = do ] lineMapper :: Text -> InputLine lineMapper line = case Parsec.runParser specialLineParser () "" line of - Left _e -> NormalLine line - Right l -> l + Left _e -> NormalLine line + Right l -> l lineIsSpace :: InputLine -> Bool lineIsSpace CommentLine = True - lineIsSpace _ = False + lineIsSpace _ = False grouperG :: InputLine -> InputLine -> Bool grouperG _ GroupLine{} = False - grouperG _ _ = True + grouperG _ _ = True grouperT :: InputLine -> InputLine -> Bool grouperT _ HeaderLine{} = False - grouperT _ _ = True + grouperT _ _ = True -------------------- @@ -220,42 +225,43 @@ instance Show PPTextWrapper where show (PPTextWrapper t) = "\n" ++ Text.unpack t -- brittany-next-binding --columns 160 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } defaultTestConfig :: Config defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_importAsColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } - , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } + , _conf_preprocessor = _conf_preprocessor staticDefaultConfig + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config contextFreeTestConfig = defaultTestConfig { _conf_layout = (_conf_layout defaultTestConfig) - { _lconfig_indentPolicy = coerce IndentPolicyLeft - , _lconfig_alignmentLimit = coerce (1 :: Int) - , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } + { _lconfig_indentPolicy = coerce IndentPolicyLeft + , _lconfig_alignmentLimit = coerce (1 :: Int) + , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled + } }