diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 456ef4a..06cbb63 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -75,35 +75,36 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do [ ( k , [ x | (ExactPrint.Comment x _ _, _) <- - ( ExactPrint.annPriorComments ann + (ExactPrint.annPriorComments ann ++ ExactPrint.annFollowingComments ann ) ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] ) | (k, ann) <- Map.toList anns ] - let configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - ( ("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) + let + configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + (("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) let configParser = Butcher.addAlternatives [ ( "commandline-config" @@ -122,39 +123,44 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do ] parser = do -- we will (mis?)use butcher here to parse the inline config -- line. - let nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + let + nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + let + nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding - let disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let + disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) + let + disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) + let + disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do @@ -162,30 +168,31 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) Butcher.addNullCmd $ do bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser + conf <- configParser Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) conf <- configParser Butcher.addCmdImpl (InlineConfigTargetModule, conf) lineConfigss <- configLiness `forM` \(k, ss) -> do r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c + Left err -> Left $ (err, s) + Right c -> Right $ c pure (k, r) - let perModule = foldl' - (<>) - mempty - [ conf - | (_ , lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf ) <- lineConfigs - ] + let + perModule = foldl' + (<>) + mempty + [ conf + | (_, lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf) <- lineConfigs + ] let perBinding = Map.fromListWith (<>) [ (n, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs - , n <- case target of + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs + , n <- case target of InlineConfigTargetBinding s -> [s] InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> [name] @@ -195,8 +202,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do perKey = Map.fromListWith (<>) [ (k, conf) - | (k , lineConfigs) <- lineConfigss - , (target, conf ) <- lineConfigs + | (k, lineConfigs) <- lineConfigss + , (target, conf) <- lineConfigs , case target of InlineConfigTargetNextDecl -> True InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> @@ -214,7 +221,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls + | decl <- decls , (name : _) <- [getDeclBindingNames decl] ] @@ -232,70 +239,76 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = -- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configWithDebugs inputText = runExceptT $ do - let config = - configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let + config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack (anns, parsedSource, hasCPP) <- do - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let + hackF s = + if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s + let + hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False parseResult <- lift $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x + Left err -> throwE [ErrorInput err] + Right x -> pure x (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting then do return inputText else do (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack + let + omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConfig perItemConf anns parsedSource else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + let + hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews - , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn - (TextL.pack "\n") - outRaw + , TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw ) else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let + hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack then not $ null errsWarns else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors @@ -315,26 +328,27 @@ pPrintModule -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf inlineConf anns parsedModule = - let ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) + let + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = if Seq.null debugStrings + then id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do -- -- debugStrings `forM_` \s -> @@ -349,15 +363,17 @@ pPrintModuleAndCheck -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] + parseResult <- parseModuleFromString + ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let + errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] return (errs', output) @@ -372,18 +388,19 @@ parsePrintModuleTests conf filename input = do (const . pure $ Right ()) inputStr case parseResult of - Left err -> return $ Left err + Left err -> return $ Left err Right (anns, parsedModule, _) -> runExceptT $ do (inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let + omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (errs, ltext) <- if omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedModule else lift @@ -393,13 +410,13 @@ parsePrintModuleTests conf filename input = do else let errStrs = errs <&> \case - ErrorInput str -> str + ErrorInput str -> str ErrorUnusedComment str -> str - LayoutWarning str -> str + LayoutWarning str -> str ErrorUnknownNode str _ -> str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs -- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally @@ -454,25 +471,26 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl + let declAnnKey = ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk - <&> \annMap -> - Map.union defaultAnns $ - Map.findWithDefault Map.empty declAnnKey annMap + let + mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk <&> \annMap -> + Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns config <- mAsk - let config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + let + config' = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do @@ -487,33 +505,34 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd - let finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post + let + finalComments = filter + (fst .> \case + ExactPrint.AnnComment{} -> True + _ -> False + ) + post post `forM_` \case (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm - | span <- ExactPrint.commentIdentifier cm - -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + let + folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> + ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] + _ -> [] -- Prints the information associated with the module annotation @@ -530,8 +549,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do -- attached annotations that come after the module's where -- from the module node config <- mAsk - let shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + let + shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack let (filteredAnns', post) = @@ -541,23 +561,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do let modAnnsDp = ExactPrint.annsDP mAnn isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False + isWhere _ = False isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp (pre, post') = case (whereInd, eofInd) of (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in - (filteredAnns'', post') - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations + in (filteredAnns'', post') + traceIfDumpConf + "bridoc annotations filtered/transformed" + _dconf_dump_annotations $ annsDoc filteredAnns' if shouldReformatPreamble @@ -566,7 +586,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule return post _sigHead :: Sig GhcPs -> String @@ -579,7 +599,7 @@ _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" @@ -597,63 +617,67 @@ layoutBriDoc briDoc = do transformAlts briDoc >>= mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt -- bridoc transformation: float stuff in mGet >>= transformSimplifyFloating .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating + .> traceIfDumpConf + "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating -- bridoc transformation: par removal mGet >>= transformSimplifyPar .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par -- bridoc transformation: float stuff in mGet >>= transformSimplifyColumns .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns -- bridoc transformation: indent mGet >>= transformSimplifyIndent .> mSet mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent mGet >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl anns :: ExactPrint.Anns <- mAsk - let state = LayoutState { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } + let + state = LayoutState + { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - let remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] + let + remainingComments = + [ c + | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + (_lstate_comments state') + -- With the new import layouter, we manually process comments + -- without relying on the backend to consume the comments out of + -- the state/map. So they will end up here, and we need to ignore + -- them. + , ExactPrint.unConName con /= "ImportDecl" + , c <- extractAllComments elemAnns + ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs index 6cfbaf3..55a3c97 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -31,16 +31,20 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -type ColIndex = Int +type ColIndex = Int data ColumnSpacing = ColumnSpacingLeaf Int | ColumnSpacingRef Int Int -type ColumnBlock a = [a] +type ColumnBlock a = [a] type ColumnBlocks a = Seq [a] -type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) +type ColMap1 + = IntMapL.IntMap {- ColIndex -} + (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 + = IntMapL.IntMap {- ColIndex -} + (Float, ColumnBlock Int, ColumnBlocks Int) -- (ratio of hasSpace, maximum, raw) data ColInfo @@ -50,20 +54,23 @@ data ColInfo instance Show ColInfo where show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + show (ColInfoNo bd) = + "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") + show (ColInfo ind sig list) = + "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list data ColBuildState = ColBuildState { _cbs_map :: ColMap1 , _cbs_index :: ColIndex } -type LayoutConstraints m = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) +type LayoutConstraints m + = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM = \case @@ -84,10 +91,11 @@ layoutBriDocM = \case BDSeparator -> do layoutAddSepSpace BDAddBaseY indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ layoutBriDocM bd BDBaseYPushCur bd -> do layoutBaseYPushCur @@ -102,36 +110,39 @@ layoutBriDocM = \case layoutBriDocM bd layoutIndentLevelPop BDEnsureIndent indent bd -> do - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteEnsureBlock layoutBriDocM bd BDPar indent sameLine indented -> do layoutBriDocM sameLine - let indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i + let + indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i indentF $ do layoutWriteNewlineBlock layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt:_) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt : _) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd BDExternal annKey subKeys shouldAddComment t -> do - let tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines + let + tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines anns :: ExactPrint.Anns <- mAsk when shouldAddComment $ do layoutWriteAppend - $ Text.pack - $ "{-" + $ Text.pack + $ "{-" ++ show (annKey, Map.lookup annKey anns) ++ "-}" zip [1 ..] tlines `forM_` \(i, l) -> do @@ -148,9 +159,10 @@ layoutBriDocM = \case BDAnnotationPrior annKey bd -> do state <- mGet let m = _lstate_comments state - let moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey + let + moveToExactLocationAction = case _lstate_curYOrAddNewline state of + Left{} -> pure () + Right{} -> moveToExactAnn annKey mAnn <- do let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m mSet $ state @@ -161,8 +173,8 @@ layoutBriDocM = \case } return mAnn case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction + Nothing -> moveToExactLocationAction + Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace priors @@ -170,9 +182,10 @@ layoutBriDocM = \case when (comment /= "(" && comment /= ")") $ do let commentLines = Text.lines $ Text.pack $ comment case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y @@ -184,18 +197,20 @@ layoutBriDocM = \case layoutBriDocM bd mComments <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let mToSpan = case mAnn of - Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just - annR - _ -> Nothing + let + mToSpan = case mAnn of + Just anns | Maybe.isNothing keyword -> Just anns + Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> + Just annR + _ -> Nothing case mToSpan of Just anns -> do - let (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing + let + (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing mSet $ state { _lstate_comments = Map.adjust (\ann -> ann { ExactPrint.annsDP = rest }) @@ -207,17 +222,19 @@ layoutBriDocM = \case case mComments of Nothing -> pure () Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack $ comment + -- evil hack for CPP: + case comment of + ('#' : _) -> + layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd @@ -226,21 +243,26 @@ layoutBriDocM = \case let m = _lstate_comments state pure $ Map.lookup annKey m let mComments = nonEmpty . extractAllComments =<< annMay - let semiCount = length [ () - | Just ann <- [ annMay ] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- mAsk <&> - _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack + let + semiCount = length + [ () + | Just ann <- [annMay] + , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + ] + shouldAddSemicolonNewlines <- + mAsk + <&> _conf_layout + .> _lconfig_experimentalSemicolonNewlines + .> confUnpack mModify $ \state -> state { _lstate_comments = Map.adjust - ( \ann -> ann { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = - flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } + (\ann -> ann + { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True + } ) annKey (_lstate_comments state) @@ -248,37 +270,40 @@ layoutBriDocM = \case case mComments of Nothing -> do when shouldAddSemicolonNewlines $ do - [1..semiCount] `forM_` const layoutWriteNewline + [1 .. semiCount] `forM_` const layoutWriteNewline Just comments -> do - comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines + comments + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + when (comment /= "(" && comment /= ")") $ do + let commentLines = Text.lines $ Text.pack comment + case comment of + ('#' : _) -> layoutMoveToCommentPos y (-999) 1 + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs + _ -> layoutMoveToCommentPos y x (length commentLines) + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet - let m = _lstate_comments state + let m = _lstate_comments state let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let relevant = [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] + let + relevant = + [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] case relevant of [] -> pure Nothing - (ExactPrint.Types.DP (y, x):_) -> do + (ExactPrint.Types.DP (y, x) : _) -> do mSet state { _lstate_commentNewlines = 0 } pure $ Just (y - _lstate_commentNewlines state, x) case mDP of @@ -289,8 +314,8 @@ layoutBriDocM = \case layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" layoutBriDocM bd @@ -301,73 +326,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc -- appended at the current position. where rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc where rec :: BriDoc -> Bool rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_ ] -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd -- In theory -- ========= @@ -452,16 +477,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe 0 (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack case () of _ -> do -- tellDebugMess ("processedMap: " ++ show processedMap) sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos <&> processInfo colMax processedMap where (colInfos, finalState) = @@ -478,40 +503,39 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do where alignMax' = max 0 alignMax processedMap :: ColMap2 - processedMap = - fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + processedMap = fix $ \result -> + _cbs_map finalState <&> \(lastFlag, colSpacingss) -> let colss = colSpacingss <&> \spss -> case reverse spss of [] -> [] - (xN:xR) -> + (xN : xR) -> reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR where - fLast (ColumnSpacingLeaf len ) = len + fLast (ColumnSpacingLeaf len) = len fLast (ColumnSpacingRef len _) = len fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of - Nothing -> 0 + fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of + Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} fmap colAggregation $ transpose $ Foldable.toList colss (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + mapAccumL (\acc x -> (acc + x, acc)) curX maxCols counter count l = if List.last posXs + List.last l <= colMax then count + 1 else count ratio = fromIntegral (foldl counter (0 :: Int) colss) / fromIntegral (length colss) - in - (ratio, maxCols, colss) + in (ratio, maxCols, colss) mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd:bdr) = do - info <- mergeInfoBriDoc True lastInfo bd + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd : bdr) = do + info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info) @@ -539,28 +563,27 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -- personal preference to not break alignment for those, even if -- multiline. Really, this should be configurable.. (TODO) shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = alignBreak && - briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True + shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp{} _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True mergeInfoBriDoc :: Bool @@ -568,23 +591,22 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -> BriDoc -> StateS.StateT ColBuildState Identity ColInfo mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs - -> do + | infoSig == colSig && length subLengthsInfos == length subDocs -> do let isLastList = if lastFlag - then (==length subDocs) <$> [1 ..] + then (== length subDocs) <$> [1 ..] else repeat False infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs + let curLengths = briDocLineLength <$> subDocs let trueSpacings = getTrueSpacings (zip curLengths infos) do -- update map s <- StateS.get - let m = _cbs_map s + let m = _cbs_map s let (Just (_, spaces)) = IntMapS.lookup infoInd m StateS.put s { _cbs_map = IntMapS.insert @@ -593,17 +615,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do m } return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise - -> briDocToColInfo lastFlag brdc + | otherwise -> briDocToColInfo lastFlag brdc brdc -> return $ ColInfoNo brdc briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo lastFlag = \case BDCols sig list -> withAlloc lastFlag $ \ind -> do - let isLastList = - if lastFlag then (==length list) <$> [1 ..] else repeat False + let + isLastList = + if lastFlag then (== length list) <$> [1 ..] else repeat False subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos + let lengthInfos = zip (briDocLineLength <$> list) subInfos let trueSpacings = getTrueSpacings lengthInfos return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) bd -> return $ ColInfoNo bd @@ -611,11 +633,11 @@ briDocToColInfo lastFlag = \case getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings lengthInfos = lengthInfos <&> \case (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _ ) -> ColumnSpacingLeaf len + (len, _) -> ColumnSpacingLeaf len withAlloc :: Bool - -> ( ColIndex + -> ( ColIndex -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) ) -> StateS.State ColBuildState ColInfo @@ -630,13 +652,13 @@ withAlloc lastFlag f = do processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ do colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do + curX <- do state <- mGet -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state @@ -648,10 +670,11 @@ processInfo maxSpace m = \case let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l + let + maxCols2 = list <&> \case + (_, ColInfo i _ _) -> + let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (l, _) -> l let maxCols = zipWith max maxCols1 maxCols2 let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols -- handle the cases that the vertical alignment leads to more than max @@ -662,46 +685,48 @@ processInfo maxSpace m = \case -- sizes in such a way that it works _if_ we have sizes (*factor) -- in each column. but in that line, in the last column, we will be -- forced to occupy the full vertical space, not reduced by any factor. - let fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (*factor) .> truncate - _ -> posXs - let spacings = zipWith (-) - (List.tail fixedPosXs ++ [min maxX colMax]) - fixedPosXs + let + fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (* factor) .> truncate + _ -> posXs + let + spacings = + zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs -- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct + let + alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + if List.last fixedPosXs + fst (List.last list) > colMax + -- per-item check if there is overflowing. + then noAlignAct + else alignAct case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct processInfoIgnore :: LayoutConstraints m => ColInfo -> m () processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index 919a323..310ea56 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -22,17 +22,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -traceLocal - :: (MonadMultiState LayoutState m) - => a - -> m () +traceLocal :: (MonadMultiState LayoutState m) => a -> m () traceLocal _ = return () layoutWriteAppend - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Text -> m () layoutWriteAppend t = do @@ -48,15 +43,13 @@ layoutWriteAppend t = do mTell $ Text.Builder.fromText $ t mModify $ \s -> s { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces , _lstate_addSepSpace = Nothing } layoutWriteAppendSpaces - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () layoutWriteAppendSpaces i = do @@ -64,20 +57,18 @@ layoutWriteAppendSpaces i = do unless (i == 0) $ do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state + { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state } layoutWriteAppendMultiline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => [Text] -> m () layoutWriteAppendMultiline ts = do traceLocal ("layoutWriteAppendMultiline", ts) case ts of - [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. - (l:lr) -> do + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. + (l : lr) -> do layoutWriteAppend l lr `forM_` \x -> do layoutWriteNewline @@ -85,16 +76,15 @@ layoutWriteAppendMultiline ts = do -- adds a newline and adds spaces to reach the base column. layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteNewlineBlock = do traceLocal ("layoutWriteNewlineBlock") state <- mGet - mSet $ state { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - } + mSet $ state + { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + } -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- , MonadMultiWriter (Seq String) m) => Int -> m () @@ -110,13 +100,13 @@ layoutWriteNewlineBlock = do -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } -layoutSetCommentCol - :: (MonadMultiState LayoutState m) => m () +layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol = do state <- mGet - let col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + let + col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state traceLocal ("layoutSetCommentCol", col) unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } @@ -124,9 +114,7 @@ layoutSetCommentCol = do -- This is also used to move to non-comments in a couple of places. Seems -- to be harmless so far.. layoutMoveToCommentPos - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> Int -> Int @@ -136,38 +124,35 @@ layoutMoveToCommentPos y x commentLines = do state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y + Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = + , _lstate_addSepSpace = Just $ if Data.Maybe.isJust (_lstate_commentCol state) then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = - Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_commentCol = Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 + _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteNewline = do traceLocal ("layoutWriteNewline") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing + , _lstate_addSepSpace = Nothing } _layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () @@ -175,77 +160,66 @@ _layoutResetCommentNewlines = do mModify $ \state -> state { _lstate_commentNewlines = 0 } layoutWriteEnsureNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteEnsureNewlineBlock = do traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 + Left{} -> Right 1 Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing } layoutWriteEnsureAbsoluteN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c , _ ) -> n - c - (Nothing, Left i ) -> n - i - (Nothing, Right{}) -> n + let + diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c, _) -> n - c + (Nothing, Left i) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to + mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to -- at least (Just 1), so we won't -- overwrite any old value in any -- bad way. - } -layoutBaseYPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () +layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m () layoutBaseYPushInternal i = do traceLocal ("layoutBaseYPushInternal", i) mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } -layoutBaseYPopInternal - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal = do traceLocal ("layoutBaseYPopInternal") mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } -layoutIndentLevelPushInternal - :: (MonadMultiState LayoutState m) - => Int - -> m () +layoutIndentLevelPushInternal :: (MonadMultiState LayoutState m) => Int -> m () layoutIndentLevelPushInternal i = do traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } -layoutIndentLevelPopInternal - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal = do traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } + mModify $ \s -> s + { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } -layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () +layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger = do - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - } + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } layoutWithAddBaseCol :: ( MonadMultiWriter Text.Builder.Builder m @@ -277,9 +251,7 @@ layoutWithAddBaseColBlock m = do layoutBaseYPopInternal layoutWithAddBaseColNBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () -> m () @@ -292,27 +264,23 @@ layoutWithAddBaseColNBlock amount m = do layoutBaseYPopInternal layoutWriteEnsureBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteEnsureBlock = do traceLocal ("layoutWriteEnsureBlock") state <- mGet let diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i ) -> lstate_baseY state - i + (Nothing, Left i) -> lstate_baseY state - i (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i ) -> max sp (lstate_baseY state - i) + (Just sp, Left i) -> max sp (lstate_baseY state - i) (Just sp, Right{}) -> max sp (lstate_baseY state) -- when (diff>0) $ layoutWriteNewlineBlock when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just $ diff } layoutWithAddBaseColN - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Int -> m () -> m () @@ -322,39 +290,36 @@ layoutWithAddBaseColN amount m = do m layoutBaseYPopInternal -layoutBaseYPushCur - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur = do traceLocal ("layoutBaseYPushCur") state <- mGet case _lstate_commentCol state of Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> layoutBaseYPushInternal (i + j) - (Left i , Nothing) -> layoutBaseYPushInternal i - (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state + (Left i, Just j) -> layoutBaseYPushInternal (i + j) + (Left i, Nothing) -> layoutBaseYPushInternal i + (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state Just cCol -> layoutBaseYPushInternal cCol -layoutBaseYPop - :: (MonadMultiState LayoutState m) => m () +layoutBaseYPop :: (MonadMultiState LayoutState m) => m () layoutBaseYPop = do traceLocal ("layoutBaseYPop") layoutBaseYPopInternal -layoutIndentLevelPushCur - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur = do traceLocal ("layoutIndentLevelPushCur") state <- mGet - let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i , Just j ) -> i + j - (Left i , Nothing) -> i - (Right{}, Just j ) -> j - (Right{}, Nothing) -> 0 + let + y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> i + j + (Left i, Nothing) -> i + (Right{}, Just j) -> j + (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y -layoutIndentLevelPop - :: (MonadMultiState LayoutState m) => m () +layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop = do traceLocal ("layoutIndentLevelPop") layoutIndentLevelPopInternal @@ -364,12 +329,12 @@ layoutIndentLevelPop = do -- make sense. layoutRemoveIndentLevelLinger -layoutAddSepSpace :: (MonadMultiState LayoutState m) - => m () +layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () layoutAddSepSpace = do state <- mGet mSet $ state - { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state + } -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. @@ -384,7 +349,7 @@ moveToExactAnn annKey = do traceLocal ("moveToExactAnn", annKey) anns <- mAsk case Map.lookup annKey anns of - Nothing -> return () + Nothing -> return () Just ann -> do -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann @@ -393,19 +358,19 @@ moveToExactAnn annKey = do moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY y = mModify $ \state -> - let upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then - _lstate_commentCol state - <|> _lstate_addSepSpace state - <|> Just (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } + let + upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in + state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just + (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do @@ -415,9 +380,7 @@ moveToY y = mModify $ \state -> -- else x ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m - => ExactPrint.DeltaPos - -> m () + :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ y $ mTell $ Text.Builder.fromString " " @@ -433,75 +396,77 @@ layoutWritePriorComments layoutWritePriorComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annPriorComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just priors -> do unless (null priors) $ layoutSetCommentCol - priors `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment + priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> + do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. -- per documentation, this seems sufficient, as the -- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m) - => Located ast -> m () +layoutWritePostComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + ) + => Located ast + -> m () layoutWritePostComments ast = do mAnn <- do state <- mGet - let key = ExactPrint.mkAnnKey ast + let key = ExactPrint.mkAnnKey ast let anns = _lstate_comments state let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns mSet $ state - { _lstate_comments = - Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns } return mAnn case mAnn of Nothing -> return () Just posts -> do unless (null posts) $ layoutSetCommentCol - posts `forM_` \( ExactPrint.Comment comment _ _ - , ExactPrint.DP (x, y) - ) -> do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment + posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> + do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment - :: ( MonadMultiState LayoutState m - , MonadMultiWriter Text.Builder.Builder m - ) + :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) => m () layoutIndentRestorePostComment = do state <- mGet let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state - mModify $ \s -> s { _lstate_commentCol = Nothing - , _lstate_commentNewlines = 0 - } + let eCurYAddNL = _lstate_curYOrAddNewline state + mModify + $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) - _ -> return () + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe + 0 + (_lstate_addSepSpace state) + _ -> return () -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs index 08d0fd4..040320b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config.hs @@ -27,151 +27,151 @@ import UI.Butcher.Monadic -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] } -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") - dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") - dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") - dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") - dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") - dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") - dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = mempty } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty + , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Bool.bool Nothing (Just True) @@ -218,8 +218,8 @@ readConfig path = do fileConf <- case Data.Yaml.decodeEither' contents of Left e -> do liftIO - $ putStrErrLn - $ "error reading in brittany config from " + $ putStrErrLn + $ "error reading in brittany config from " ++ path ++ ":" liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) @@ -233,11 +233,12 @@ readConfig path = do userConfigPath :: IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith Directory.doesFileExist - searchDirs - "config.yaml" + globalConfig <- Directory.findFileWith + Directory.doesFileExist + searchDirs + "config.yaml" maybe (writeUserConfig userBritPathXdg) pure globalConfig where writeUserConfig dir = do @@ -249,7 +250,7 @@ userConfigPath = do -- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir + let dirParts = FilePath.splitDirectories dir -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" @@ -261,8 +262,9 @@ readConfigs -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let merged = Semigroup.sconcat - $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + let + merged = + Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index bb7148d..0f0075a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -23,40 +23,40 @@ confUnpack :: Coercible a b => Identity a -> b confUnpack (Identity x) = coerce x data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. , _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentAmount :: f (Last Int) , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) + , _lconfig_importColumn :: f (Last Int) -- ^ for import statement layouting, column at which to align the -- elements to be imported from a module. -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) + , _lconfig_importAsColumn :: f (Last Int) -- ^ for import statement layouting, column at which put the module's -- "as" name (which also affects the positioning of the "as" keyword). -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) + , _lconfig_alignmentLimit :: f (Last Int) -- roughly speaking, this sets an upper bound to the number of spaces -- inserted to create horizontal alignment. -- More specifically, if 'xs' are the widths of the columns in some @@ -141,17 +141,17 @@ data CLayoutConfig f = LayoutConfig -- -- > , y :: Double -- -- > } } - deriving (Generic) + deriving Generic data CForwardOptions f = ForwardOptions { _options_ghc :: f [String] } - deriving (Generic) + deriving Generic data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) -- ^ Determines when to fall back on the exactprint'ed output when -- syntactical constructs are encountered which are not yet handled by -- brittany. @@ -161,21 +161,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig -- has different semantics than the code pre-transformation. , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CPreProcessorConfig f = PreProcessorConfig { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config @@ -186,10 +186,9 @@ data CConfig f = Config -- module. Useful for wildcard application -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) - + , _conf_obfuscate :: f (Semigroup.Last Bool) } - deriving (Generic) + deriving Generic type DebugConfig = CDebugConfig Identity type LayoutConfig = CLayoutConfig Identity diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 0c25537..c667038 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -29,7 +29,7 @@ import Language.Haskell.Brittany.Internal.Prelude aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany = Aeson.defaultOptions { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (=='_') + , Aeson.fieldLabelModifier = dropWhile (== '_') } instance FromJSON (CDebugConfig Maybe) where @@ -104,17 +104,27 @@ instance ToJSON (CConfig Maybe) where -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- config file content. instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = Config - <$> v .:? Key.fromString "conf_version" - <*> v .:?= Key.fromString "conf_debug" - <*> v .:?= Key.fromString "conf_layout" - <*> v .:?= Key.fromString "conf_errorHandling" - <*> v .:?= Key.fromString "conf_forward" - <*> v .:?= Key.fromString "conf_preprocessor" - <*> v .:? Key.fromString "conf_roundtrip_exactprint_only" - <*> v .:? Key.fromString "conf_disable_formatting" - <*> v .:? Key.fromString "conf_obfuscate" - parseJSON invalid = Aeson.typeMismatch "Config" invalid + parseJSON (Object v) = + Config + <$> v + .:? Key.fromString "conf_version" + <*> v + .:?= Key.fromString "conf_debug" + <*> v + .:?= Key.fromString "conf_layout" + <*> v + .:?= Key.fromString "conf_errorHandling" + <*> v + .:?= Key.fromString "conf_forward" + <*> v + .:?= Key.fromString "conf_preprocessor" + <*> v + .:? Key.fromString "conf_roundtrip_exactprint_only" + <*> v + .:? Key.fromString "conf_disable_formatting" + <*> v + .:? Key.fromString "conf_obfuscate" + parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index b93fbbc..63d6b53 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -53,26 +53,30 @@ parseModuleFromString = ParseModule.parseModule commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob ast = do - let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` - (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) + let + extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` (\l@(L span _) -> + Seq.singleton (span, ExactPrint.mkAnnKey l) + ) let nodes = SYB.everything (<>) extract ast - let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] + let + annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (const id) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes + ] nodes `forM_` (snd .> processComs annsMap) where processComs annsMap annKey1 = do mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn `forM_` \ann1 -> do - let priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 + let + priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 let processCom :: (ExactPrint.Comment, ExactPrint.DeltaPos) @@ -84,31 +88,32 @@ commentAnnFixTransformGlob ast = do (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> move $> False (x, y) | x == y -> move $> False - _ -> return True + _ -> return True where ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 + loc1 = GHC.realSrcSpanStart annKeyLoc1 + loc2 = GHC.realSrcSpanStart annKeyLoc2 move = ExactPrint.modifyAnnsT $ \anns -> let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2' = ann2 { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] + ExactPrint.annFollowingComments ann2 ++ [comPair] } - in - Map.insert annKey2 ann2' anns + in Map.insert annKey2 ann2' anns _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors + priors' <- filterM processCom priors follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case + assocs' <- flip filterM assocs $ \case (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let ann1' = ann1 { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } + _ -> return True + let + ann1' = ann1 + { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns @@ -196,29 +201,30 @@ extractToplevelAnns lmod anns = output | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns ] declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + modKey = ExactPrint.mkAnnKey lmod + output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) -groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) - Map.empty +groupMap f = Map.foldlWithKey' + (\m k a -> Map.alter (insert k a) (f k a) m) + Map.empty where - insert k a Nothing = Just (Map.singleton k a) + insert k a Nothing = Just (Map.singleton k a) insert k a (Just m) = Just (Map.insert k a m) foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys ast = SYB.everything Set.union - ( \x -> maybe + (\x -> maybe Set.empty Set.singleton [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x + ] -- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- even though it is passed to mkAnnKey above, which only accepts -- SrcSpan. - ] ) ast where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) @@ -227,8 +233,8 @@ foldedAnnKeys ast = SYB.everything withTransformedAnns :: Data ast => ast - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case readers@(conf :+: anns :+: HNil) -> do -- TODO: implement `local` for MultiReader/MultiRWS @@ -238,9 +244,10 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case pure x where f anns = - let ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced + let + ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced warnExtractorCompat :: GHC.Warn -> String diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 4606eac..136468e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -56,7 +56,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString str + _ -> mTell $ Text.Builder.fromString str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -68,9 +68,10 @@ briDocByExact -> ToBriDocM BriDocNumbered briDocByExact ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns True -- | Use ExactPrint's output for this node. @@ -84,9 +85,10 @@ briDocByExactNoComment -> ToBriDocM BriDocNumbered briDocByExactNoComment ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns False -- | Use ExactPrint's output for this node, presuming that this output does @@ -99,24 +101,26 @@ briDocByExactInlineOnly -> ToBriDocM BriDocNumbered briDocByExactInlineOnly infoStr ast = do anns <- mAsk - traceIfDumpConf "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t - let errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit - $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + let + exactPrintNode t = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + t + let + errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _ ) -> errorAction - (_ , [t]) -> exactPrintNode + (ExactPrintFallbackModeNever, _) -> errorAction + (_, [t]) -> exactPrintNode (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted _ -> errorAction @@ -141,20 +145,21 @@ lrdrNameToTextAnnGen lrdrNameToTextAnnGen f ast@(L _ n) = do anns <- mAsk let t = f $ rdrNameToText n - let hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False + let + hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. -- whatever we don't probably should have had some effect on the -- output. in such cases, resorting to byExact is probably the safe -- choice. return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t + Nothing -> t Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t lrdrNameToTextAnn :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) @@ -167,9 +172,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial => Located RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + let + f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x lrdrNameToTextAnnGen f ast -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects @@ -187,10 +193,11 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick -> m Text lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + x <- lrdrNameToTextAnn ast2 + let + lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x return $ if hasQuote then Text.cons '\'' lit else lit askIndent :: (MonadMultiReader Config m) => m Int @@ -208,12 +215,11 @@ extractRestComments ann = ExactPrint.annFollowingComments ann ++ (ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] + _ -> [] ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = - Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) -- | True if there are any comments that are -- a) connected to any node below (in AST sense) the given node AND @@ -231,15 +237,16 @@ hasCommentsBetween -> ToBriDocM Bool hasCommentsBetween ast leftKey rightKey = do mAnn <- astAnn ast - let go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest + let + go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest case mAnn of - Nothing -> pure False + Nothing -> pure False Just ann -> pure $ go1 $ ExactPrint.annsDP ann -- | True if there are any comments that are connected to any node below (in AST @@ -286,7 +293,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case hasAnnKeywordComment :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False + Nothing -> False Just ann -> any hasK (extractAllComments ann) where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst @@ -300,7 +307,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks where hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False + hasK _ = False astAnn :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) @@ -449,16 +456,13 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) deriving (Functor, Applicative, Monad) addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = - when cond (addAlternative doc) +addAlternativeCond cond doc = when cond (addAlternative doc) addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = - CollectAltM . Writer.tell . (: []) +addAlternative = CollectAltM . Writer.tell . (: []) runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered -runFilteredAlternative (CollectAltM action) = - docAlt $ Writer.execWriter action +runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered @@ -506,7 +510,8 @@ docAnnotationKW -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm +docAnnotationKW annKey kw bdm = + allocateNode . BDFAnnotationKW annKey kw =<< bdm docMoveToKWDP :: AnnKey @@ -558,7 +563,7 @@ docParenR :: ToBriDocM BriDocNumbered docParenR = docLit $ Text.pack ")" docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] docParenHashRSep :: ToBriDocM BriDocNumbered docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] @@ -620,32 +625,26 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNodePrior ast bdm = do bd <- bdm i1 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ bd + return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd docWrapNodeRest ast bdm = do bd <- bdm i2 <- allocNodeIndex - return - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd + return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where docWrapNode ast bdms = case bdms of [] -> [] [bd] -> [docWrapNode ast bd] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdms = case bdms of [] -> [] [bd] -> [docWrapNodePrior ast bd] - (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR + (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + [] -> [] + (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do @@ -655,25 +654,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] - (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do + (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ [bd1'] ++ reverse bdM ++ [bdN'] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdsm = do bds <- bdsm case bds of [] -> return [] - (bd1:bdR) -> do + (bd1 : bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return (bd1':bdR) + return (bd1' : bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of [] -> return [] - (bdN:bdR) -> do + (bdN : bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN':bdR) + return $ reverse (bdN' : bdR) instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do @@ -686,7 +685,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where return $ Seq.singleton bd1' bdM Seq.:> bdN -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ (bd1' Seq.<| bdM) Seq.|> bdN' docWrapNodePrior ast bdsm = do bds <- bdsm @@ -730,7 +729,7 @@ docPar -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docPar lineM indentedM = do - line <- lineM + line <- lineM indented <- indentedM allocateNode $ BDFPar BrIndentNone line indented @@ -767,14 +766,15 @@ briDocMToPPM m = do briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR - let ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m + let + ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index dc7d022..37f648e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -27,28 +27,29 @@ layoutDataDecl -> ToBriDocM BriDocNumbered layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> - docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) + -> docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl -- data MyData a b @@ -56,8 +57,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs createDerivingPar mDerivs $ docSeq [ appSep $ docLitS "data" , lhsContextDoc @@ -69,24 +70,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- data MyData = MyData { .. } HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> - docWrapNode ltycl $ do + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) + -> docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- return <$> createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing + Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- return <$> createDetailsDoc consNameStr details - consDoc <- fmap pure + rhsDoc <- return <$> createDetailsDoc consNameStr details + consDoc <- + fmap pure $ docNonBottomSpacing $ case (forallDocMay, rhsContextDocMay) of (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [ docLitS "." , docSeparator @@ -94,7 +97,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of ] ] (Just forallDoc, Nothing) -> docLines - [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + [ docSeq + [docLitS "=", docSeparator, docForceSingleline forallDoc] , docSeq [docLitS ".", docSeparator, rhsDoc] ] (Nothing, Just rhsContextDoc) -> docSeq @@ -102,12 +106,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSeparator , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] ] - (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] + (Nothing, Nothing) -> + docSeq [docLitS "=", docSeparator, rhsDoc] createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline $ lhsContextDoc , appSep $ docLit nameStr @@ -119,12 +123,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -132,26 +137,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr , tyVarLine ] ) - ( docSeq + (docSeq [ docLitS "=" , docSeparator , docSetIndentLevel $ docSeq [ case forallDocMay of Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] + Just forallDoc -> + docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] , maybe docEmpty docForceSingleline rhsContextDocMay , rhsDoc ] @@ -162,8 +167,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq + (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -184,13 +188,10 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- hurt. docAddBaseY BrIndentRegular $ docPar (docLitS "data") - ( docLines + (docLines [ lhsContextDoc , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLit nameStr - , tyVarLine - ] + $ docSeq [appSep $ docLit nameStr, tyVarLine] , consDoc ] ) @@ -204,20 +205,20 @@ createContextDoc [] = docEmpty createContextDoc [t] = docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 + t1Doc <- docSharedWrapper layoutType t1 tRDocs <- tR `forM` docSharedWrapper layoutType docAlt [ docSeq [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse docCommaSep - (t1Doc : tRDocs) + , docForceSingleline $ docSeq $ List.intersperse + docCommaSep + (t1Doc : tRDocs) , docLitS ") =>" , docSeparator ] , docLines $ join [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs - <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] , [docLitS ") =>", docSeparator] ] ] @@ -229,20 +230,18 @@ createBndrDoc bs = do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) - docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] + docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> + case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -251,10 +250,10 @@ createDerivingPar derivs mainDoc = do (L _ []) -> mainDoc (L _ types) -> docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered @@ -263,36 +262,33 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of (L _ ts) -> let tsLength = length ts - whenMoreThan1Type val = - if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in - docSeq - [ docDeriving - , docWrapNodePrior types $ lhsStrategy - , docSeparator - , whenMoreThan1Type "(" - , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts <&> \case + whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = + maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in docSeq + [ docDeriving + , docWrapNodePrior types $ lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docWrapNodeRest types + $ docSeq + $ List.intersperse docCommaSep + $ ts + <&> \case HsIB _ t -> layoutType t - , whenMoreThan1Type ")" - , rhsStrategy - ] + , whenMoreThan1Type ")" + , rhsStrategy + ] where strategyLeftRight = \case - (L _ StockStrategy ) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes) ) -> + (L _ StockStrategy) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) + lVia@(L _ (ViaStrategy viaTypes)) -> ( docEmpty , case viaTypes of - HsIB _ext t -> docSeq - [ docWrapNode lVia $ docLitS " via" - , docSeparator - , layoutType t - ] + HsIB _ext t -> + docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] ) docDeriving :: ToBriDocM BriDocNumbered @@ -302,21 +298,24 @@ createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq [ docLit consNameStr , docSeparator , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ fmap hsScaledThing args <&> layoutType + $ docSeq + $ List.intersperse docSeparator + $ fmap hsScaledThing args + <&> layoutType ] - leftIndented = docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType <$> fmap hsScaledThing args + leftIndented = + docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType + <$> fmap hsScaledThing args multiAppended = docSeq [ docLit consNameStr , docSeparator @@ -326,79 +325,80 @@ createDetailsDoc consNameStr details = case details of (docLit consNameStr) (docLines $ layoutType <$> fmap hsScaledThing args) case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyFree -> docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_:_)) -> do + RecCon (L _ []) -> + docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_ : _)) -> do let ((fName1, fType1) : fDocR) = mkFieldDocs fields -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False - docAddBaseY BrIndentRegular - $ runFilteredAlternative - $ do + docAddBaseY BrIndentRegular $ runFilteredAlternative $ do -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols + ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols + ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 + , docForceSingleline fType ] , docSeq - [ docLitS "{" + [ docLitS "," , docSeparator , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) + fName + (docSeq [docLitS "::", docSeparator, fType]) ] ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType - ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] - , docLitS "}" - ] - ) + , docLitS "}" + ] + ) InfixCon arg1 arg2 -> docSeq [ layoutType $ hsScaledThing arg1 , docSeparator @@ -413,10 +413,11 @@ createDetailsDoc consNameStr details = case details of mkFieldDocs = fmap $ \lField -> case lField of L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t -createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = Just $ docSeq - [docLitS "forall ", createBndrDoc lhsTyVarBndrs] +createForallDoc + :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = + Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc :: Data.Data.Data ast @@ -426,12 +427,8 @@ createNamesAndTypeDoc -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \case - L _ (FieldOcc _ fieldName) -> - docLit =<< lrdrNameToTextAnn fieldName + [ docSeq $ List.intersperse docCommaSep $ names <&> \case + L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName ] , docWrapNodeRest lField $ layoutType t ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index db58abc..9e22b6e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -42,11 +42,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint layoutDecl :: ToBriDoc HsDecl layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) + SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> @@ -64,47 +64,54 @@ layoutSig lsig@(L _loc sig) = case sig of docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name specStr <- specStringCompat lsig spec - let phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " + let + phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let + conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ + PatSynSig _ names (HsIB _ typ) -> + layoutNamesAndType (Just "pattern") names typ _ -> briDocByExactNoComment lsig -- TODO where layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] + let + keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- mAsk - <&> _conf_layout - .> _lconfig_hangingTypeSignature - .> confUnpack + shouldBeHanging <- + mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging - then docSeq $ - [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc + then + docSeq + $ [ appSep + $ docWrapNodeRest lsig + $ docSeq + $ keyDoc + <> [docLit nameStr] + , docSetBaseY $ docLines + [ docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ] ] - ] - ] else layoutLhsAndType hasComments (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) @@ -114,22 +121,23 @@ layoutSig lsig@(L _loc sig) = case sig of specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " + NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + Inline -> pure "INLINE " + Inlinable -> pure "INLINABLE " + NoInline -> pure "NOINLINE " layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body + BodyStmt _ body _ _ -> layoutExpr body BindStmt _ lPat expr -> do patDoc <- docSharedWrapper layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr - docCols ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO + docCols + ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- @@ -137,37 +145,33 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -------------------------------------------------------------------------------- layoutBind - :: ToBriDocC - (HsBindLR GhcPs GhcPs) - (Either [BriDocNumbered] BriDocNumbered) + :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" funcPatDocs <- docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches return $ Left $ funcPatDocs PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat + patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" + binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal + Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereArg + hasComments PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID - lpat - dir - rpat + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of @@ -177,7 +181,13 @@ layoutIPBind lipbind@(L _ bind) = case bind of binderDoc <- docLit $ Text.pack "=" exprDoc <- layoutExpr expr hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments + layoutPatternBindFinal + Nothing + binderDoc + (Just ipName) + [([], exprDoc, expr)] + Nothing + hasComments data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) @@ -185,7 +195,7 @@ data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) @@ -195,18 +205,18 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + let + unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s + BagSig s -> return <$> layoutSig s return $ Just $ docs -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> - Just <$> mapM layoutIPBind bb + HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb EmptyLocalBinds{} -> return $ Nothing -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is @@ -216,7 +226,7 @@ layoutGrhs -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body + bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) layoutPatternBind @@ -225,7 +235,7 @@ layoutPatternBind -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match + let pats = m_pats match let (GRHSs _ grhss whereBinds) = m_grhss match patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match @@ -234,25 +244,26 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do _ -> pure Nothing let mIdStr' = fixPatternBindIdentifier match <$> mIdStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1:p2:pr) | isInfix -> if null pr - then - docCols ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else - docCols ColPatternsFuncInfix - ( [docCols ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR - ] + (Just idStr, p1 : p2 : pr) | isInfix -> if null pr + then docCols + ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + ] + else docCols + ColPatternsFuncInfix + ([ docCols + ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ docLit $ idStr + , docForceSingleline p2 + , appSep $ docParenR ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) + ] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix @@ -266,30 +277,30 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments + layoutPatternBindFinal + alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereArg + hasComments -fixPatternBindIdentifier - :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text +fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match where go = \case - (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr + (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1 ) -> goInner ctx1 - _ -> idStr + (StmtCtxt ctx1) -> goInner ctx1 + _ -> idStr -- I have really no idea if this path ever occurs, but better safe than -- risking another "drop bangpatterns" bugs. goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 + (PatGuard ctx1) -> go ctx1 + (ParStmtCtxt ctx1) -> goInner ctx1 (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr + _ -> idStr layoutPatternBindFinal :: Maybe Text @@ -300,304 +311,302 @@ layoutPatternBindFinal -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do - let patPartInline = case mPatDoc of - Nothing -> [] +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments + = do + let + patPartInline = case mPatDoc of + Nothing -> [] Just patDoc -> [appSep $ docForceSingleline $ return patDoc] patPartParWrap = case mPatDoc of - Nothing -> id + Nothing -> id Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- mAsk - <&> _conf_layout - .> _lconfig_indentWhereSpecial - .> confUnpack - regularIndentAmount <- mAsk - <&> _conf_layout - .> _lconfig_indentAmount - .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt - [ docEnsureIndent BrIndentRegular - $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False + whereIndent <- do + shouldSpecial <- + mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack + regularIndentAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + [ docEnsureIndent BrIndentRegular + $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docMoveToKWDP annKeyWhere AnnWhere False $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty + ] + ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let + singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse docCommaSep - (docForceSingleline . return <$> gs) + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + gs -> + docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ (List.intersperse + docCommaSep + (docForceSingleline . return <$> gs) ) wherePart = case mWhereDocs of - Nothing -> Just docEmpty + Nothing -> Just docEmpty Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] - _ -> Nothing + _ -> Nothing - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - runFilteredAlternative $ do + runFilteredAlternative $ do - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' + case clauseDocs of + [(guards, body, _bodyRaw)] -> do + let guardPart = singleLineGuardsDoc guards + forM_ wherePart $ \wherePart' -> + -- one-line solution + addAlternativeCond (not hasComments) $ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart' + ] ] - ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine + -- one-line solution + where in next line(s) + addAlternativeCond (Data.Maybe.isJust mWhereDocs) + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + ++ wherePartMultiLine + -- two-line solution + where in next line(s) + addAlternative + $ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body as par; + -- where in following lines + addAlternative + $ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return + body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + -- pattern and exactly one clause in single line, body in new line. + addAlternative + $ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docNonBottomSpacing + $ docEnsureIndent BrIndentRegular + $ docAddBaseY BrIndentRegular + $ return body + ] + ++ wherePartMultiLine - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` + _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix + case mPatDoc of + Nothing -> return () + Just patDoc -> + -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + addAlternativeCond (indentPolicy == IndentPolicyFree) + $ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each in a separate, single line + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc ] ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - ( case guardDocs of - [] -> [] - [g] -> - [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1:gr) -> - ( docSeq [appSep $ docLit $ Text.pack "|", return g1] - : ( gr - <&> \g -> - docSeq - [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline $ docSeq + [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] - ] - ] - ++ wherePartMultiLine + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + -- conservative approach: everything starts on the left. + addAlternative + $ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + (case guardDocs of + [] -> [] + [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1 : gr) -> + (docSeq [appSep $ docLit $ Text.pack "|", return g1] + : (gr <&> \g -> + docSeq [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine -- | Layout a pattern synonym binding layoutPatSynBind @@ -607,44 +616,50 @@ layoutPatSynBind -> LPat GhcPs -> ToBriDocM BriDocNumbered layoutPatSynBind name patSynDetails patDir rpat = do - let patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" + let + patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" mWhereDocs <- layoutPatSynWhere patDir - headDoc <- fmap pure $ docSeq $ - [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] + headDoc <- + fmap pure + $ docSeq + $ [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] runFilteredAlternative $ do - addAlternative $ + addAlternative + $ -- pattern .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docSeq - ( [headDoc, docSeparator, body] - ++ case mWhereDocs of + docAddBaseY BrIndentRegular + $ docSeq + ([headDoc, docSeparator, body] ++ case mWhereDocs of Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Nothing -> [] - ) - addAlternative $ + ) + addAlternative + $ -- pattern .. = -- .. -- pattern .. <- -- .. where -- .. -- .. - docAddBaseY BrIndentRegular $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) - ) + docAddBaseY BrIndentRegular + $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) + ) -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn @@ -663,18 +678,21 @@ layoutLPatSyn name (InfixCon left right) = do layoutLPatSyn name (RecCon recArgs) = do docName <- lrdrNameToTextAnn name args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq . fmap docLit - $ [docName, Text.pack " { " ] + docSeq + . fmap docLit + $ [docName, Text.pack " { "] <> intersperse (Text.pack ", ") args <> [Text.pack " }"] -- | Helper method to get the where clause from of explicitly bidirectional -- pattern synonyms -layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere + :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of ExplicitBidirectional (MG _ (L _ lbinds) _) -> do binderDoc <- docLit $ Text.pack "=" - Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + Just + <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds _ -> pure Nothing -------------------------------------------------------------------------------- @@ -684,9 +702,10 @@ layoutPatSynWhere hs = case hs of layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl _ name vars fixity typ -> do - let isInfix = case fixity of - Prefix -> False - Infix -> True + let + isInfix = case fixity of + Prefix -> False + Infix -> True -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl @@ -715,9 +734,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do -- This isn't quite right, but does give syntactically valid results let needsParens = not (null rest) || hasOwnParens docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - ] + $ [docLit $ Text.pack "type", docSeparator] ++ [ docParenL | needsParens ] ++ [ layoutTyVarBndr False a , docSeparator @@ -729,13 +746,13 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do ++ fmap (layoutTyVarBndr True) rest else docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc @@ -744,11 +761,11 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar _ _ name -> do nameStr <- lrdrNameToTextAnn name - docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] + docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] KindedTyVar _ _ name kind -> do nameStr <- lrdrNameToTextAnn name docSeq - $ [ docSeparator | needsSep ] + $ [ docSeparator | needsSep ] ++ [ docLit $ Text.pack "(" , appSep $ docLit nameStr , appSep . docLit $ Text.pack "::" @@ -776,7 +793,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name + nameStr <- lrdrNameToTextAnn name needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass @@ -787,33 +804,34 @@ layoutTyFamInstDecl inClass outerNode tfid = do makeForallDoc bndrs = do bndrDocs <- layoutTyVarBndrs bndrs docSeq - ( [docLit (Text.pack "forall")] - ++ processTyVarBndrsSingleline bndrDocs + ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs ) lhs = docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] + . docSeq + $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] - hasComments <- (||) + hasComments <- + (||) <$> hasAnyRegularCommentsConnected outerNode <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc -layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats + :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm + HsValArg tm -> layoutType tm HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change -- is a bit strange. Hopefully this does not ignore any important -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" + HsArgPar _l -> error "brittany internal error: HsArgPar{}" -------------------------------------------------------------------------------- -- ClsInstDecl @@ -828,27 +846,27 @@ layoutClsInst :: ToBriDoc ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) ] where layoutInstanceHead :: ToBriDocM BriDocNumbered layoutInstanceHead = briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren + $ InstD NoExtField + . ClsInstD NoExtField + . removeChildren <$> lcid removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] + { cid_binds = emptyBag + , cid_sigs = [] + , cid_tyfam_insts = [] , cid_datafam_insts = [] } @@ -856,7 +874,11 @@ layoutClsInst lcid@(L _ cid) = docLines docSortedLines :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = - allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l + allocateNode + . BDFLines + . fmap unLoc + . List.sortOn (ExactPrint.rs . getLoc) + =<< sequence l layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig @@ -868,8 +890,8 @@ layoutClsInst lcid@(L _ cid) = docLines joinBinds :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n + Left ns -> docLines $ return <$> ns + Right n -> return n layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) @@ -935,10 +957,11 @@ layoutClsInst lcid@(L _ cid) = docLines stripWhitespace' t = Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t where - go [] = [] + go [] = [] go (line1 : lineR) = case Text.stripStart line1 of - st | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR + st + | isTypeOrData st -> st : lineR + | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') || (Text.pack "newtype" `Text.isPrefixOf` t') diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 9a13adf..138a748 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -29,119 +29,127 @@ import Language.Haskell.Brittany.Internal.Utils layoutExpr :: ToBriDoc HsExpr layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk - <&> _conf_layout - .> _lconfig_indentPolicy - .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree docWrapNode lexpr $ case expr of HsVar _ vname -> do docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> - docLit $ Text.pack $ occNameString oname + HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '#' : label + let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name - in docLit . Text.pack $ '?' : label + let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label HsOverLit _ olit -> do allocateNode $ overLitValBriDoc $ ol_val olit HsLit _ lit -> do allocateNode $ litBriDoc lit HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds {} <- llocals - , L _ (GRHS _ [] body) <- lgrhs + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , L _ EmptyLocalBinds{} <- llocals + , L _ (GRHS _ [] body) <- lgrhs -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let shouldPrefixSeparator = case p of + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let + shouldPrefixSeparator = case p of L _ LazyPat{} -> isFirst L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let funcPatternPartLine = - docCols ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- + docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let + funcPatternPartLine = docCols + ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing - $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docSeq + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing $ docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine - , docLit $ Text.pack "->" - ]) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> - unknownNodeError "HsLam too complex" lexpr + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> unknownNodeError "HsLam too complex" lexpr HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing $ docAddBaseY BrIndentRegular $ - (docLit $ Text.pack "\\case {}") + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ (docLit $ Text.pack "\\case {}") HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r:list) l - x -> (x, list) + let + gather + :: [LHsExpr GhcPs] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [LHsExpr GhcPs]) + gather list = \case + L _ (HsApp _ l r) -> gather (r : list) l + x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 - let colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq + let + colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs hasComments <- hasAnyCommentsConnected exp2 @@ -153,45 +161,37 @@ layoutExpr lexpr@(L _ expr) = do : spacifyDocs (docForceSingleline <$> paramDocs) -- foo x -- y - addAlternativeCond allowFreeIndent - $ docSeq + addAlternativeCond allowFreeIndent $ docSeq [ appSep (docForceSingleline headDoc) , docSetBaseY $ docAddBaseY BrIndentRegular $ docLines - $ docForceSingleline <$> paramDocs + $ docForceSingleline + <$> paramDocs ] -- foo -- x -- y - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docForceSingleline headDoc) - ( docNonBottomSpacing - $ docLines paramDocs - ) + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docForceSingleline headDoc) + (docNonBottomSpacing $ docLines paramDocs) -- ( multi -- line -- function -- ) -- x -- y - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - headDoc - ( docNonBottomSpacing - $ docLines paramDocs - ) + addAlternative $ docAddBaseY BrIndentRegular $ docPar + headDoc + (docNonBottomSpacing $ docLines paramDocs) HsApp _ exp1 exp2 -> do -- TODO: if expDoc1 is some literal, we may want to create a docCols here. expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc2 <- docSharedWrapper layoutExpr exp2 docAlt [ -- func arg - docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + docSeq + [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] , -- func argline1 -- arglines -- e.g. @@ -204,77 +204,70 @@ layoutExpr lexpr@(L _ expr) = do -- anyways, so it is _always_ par-spaced. $ docAddBaseY BrIndentRegular $ docSeq - [ appSep $ docForceSingleline expDoc1 - , docForceParSpacing expDoc2 - ] + [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] , -- func -- arg - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docForceSingleline expDoc1) (docNonBottomSpacing expDoc2) , -- fu -- nc -- ar -- gument - docAddBaseY BrIndentRegular - $ docPar - expDoc1 - expDoc2 + docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 ] HsAppType _ exp1 (HsWC _ ty1) -> do t <- docSharedWrapper layoutType ty1 e <- docSharedWrapper layoutExpr exp1 docAlt [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar - e - (docSeq [docLit $ Text.pack "@", t ]) + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar e (docSeq [docLit $ Text.pack "@", t]) ] OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft + let + gather + :: [(LHsExpr GhcPs, LHsExpr GhcPs)] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) + gather opExprList = \case + (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight + appListDocs <- appList `forM` \(x, y) -> + [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight allowSinglelinePar <- do hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp + hasComOp <- hasAnyCommentsConnected expOp pure $ not hasComLeft && not hasComOp - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True runFilteredAlternative $ do -- > one + two + three -- or -- > one + two + case x of -- > _ -> three - addAlternativeCond allowSinglelinePar - $ docSeq + addAlternativeCond allowSinglelinePar $ docSeq [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] + , docSeq $ appListDocs <&> \(od, ed) -> docSeq + [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] , appSep $ docForceSingleline opLastDoc , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc + expLastDoc ] -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) @@ -289,29 +282,31 @@ layoutExpr lexpr@(L _ expr) = do -- > one -- > + two -- > + three - addAlternative $ - docPar - leftOperandDoc - ( docLines - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + addAlternative $ docPar + leftOperandDoc + (docLines + $ (appListDocs <&> \(od, ed) -> + docCols ColOpPrefix [appSep od, docSetBaseY ed] ) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp expDocRight <- docSharedWrapper layoutExpr expRight - let allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let + leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line - addAlternative - $ docSeq + addAlternative $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceSingleline expDocRight @@ -326,35 +321,35 @@ layoutExpr lexpr@(L _ expr) = do -- two-line addAlternative $ do let - expDocOpAndRight = docForceSingleline - $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + expDocOpAndRight = docForceSingleline $ docCols + ColOpPrefix + [appSep $ expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight -- TODO: in both cases, we don't force expDocLeft to be -- single-line, which has certain.. interesting consequences. -- At least, the "two-line" label is not entirely -- accurate. -- one-line + par - addAlternativeCond allowPar - $ docSeq + addAlternativeCond allowPar $ docSeq [ appSep $ docForceSingleline expDocLeft , appSep $ docForceSingleline expDocOp , docForceParSpacing expDocRight ] -- more lines addAlternative $ do - let expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + let + expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] if leftIsDoBlock then docLines [expDocLeft, expDocOpAndRight] else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight + $ docPar expDocLeft expDocOpAndRight NegApp _ op _ -> do opDoc <- docSharedWrapper layoutExpr op - docSeq [ docLit $ Text.pack "-" - , opDoc - ] + docSeq [docLit $ Text.pack "-", opDoc] HsPar _ innerExp -> do innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt @@ -364,7 +359,8 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack ")" ] , docSetBaseY $ docLines - [ docCols ColOpPrefix + [ docCols + ColOpPrefix [ docLit $ Text.pack "(" , docAddBaseY (BrIndentSpecial 2) innerExpDoc ] @@ -373,33 +369,34 @@ layoutExpr lexpr@(L _ expr) = do ] SectionL _ left op -> do -- TODO: add to testsuite leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op docSeq [leftDoc, docSeparator, opDoc] SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op + opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple _ args boxity -> do - let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e); - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs - $ docSharedWrapper - $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- orM - ( hasCommentsBetween lexpr AnnOpenP AnnCloseP - : map hasAnyCommentsBelow args - ) - let (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) + let + argExprs = args <&> \arg -> case arg of + (L _ (Present _ e)) -> (arg, Just e) + (L _ (Missing NoExtField)) -> (arg, Nothing) + argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> + docWrapNode arg $ maybe docEmpty layoutExpr exprM + hasComments <- + orM + (hasCommentsBetween lexpr AnnOpenP AnnCloseP + : map hasAnyCommentsBelow args + ) + let + (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docParenHashLSep, docParenHashRSep) case splitFirstLast argDocs of - FirstLastEmpty -> docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) closeLit - ] + FirstLastEmpty -> + docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] FirstLastSingleton e -> docAlt - [ docCols ColTuple + [ docCols + ColTuple [ openLit , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e , closeLit @@ -414,74 +411,88 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] - addAlternative $ - let - start = docCols ColTuples - [appSep openLit, e1] - linesM = ems <&> \d -> - docCols ColTuples [docCommaSep, d] - lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + ++ [ docSeq + [ docCommaSep + , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) + , closeLit + ] + ] + addAlternative + $ let + start = docCols ColTuples [appSep openLit, e1] + linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] + lineN = docCols + ColTuples + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] HsCase _ cExp (MG _ (L _ []) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp docAlt - [ docAddBaseY BrIndentRegular - $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] + [ docAddBaseY BrIndentRegular $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") ] HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- + docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc + `mapM` matches docAlt - [ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq + [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq [ appSep $ docLit $ Text.pack "case" , appSep $ docForceSingleline cExpDoc , docLit $ Text.pack "of" - ]) - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + ] + ) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) , docPar - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - ( docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "of") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "of") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs ) + ) ] HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr + ifExprDoc <- docSharedWrapper layoutExpr ifExpr thenExprDoc <- docSharedWrapper layoutExpr thenExpr elseExprDoc <- docSharedWrapper layoutExpr elseExpr hasComments <- hasAnyCommentsBelow lexpr - let maySpecialIndent = - case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 + let + maySpecialIndent = case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 -- TODO: some of the alternatives (especially last and last-but-one) -- overlap. docSetIndentLevel $ runFilteredAlternative $ do -- if _ then _ else _ - addAlternativeCond (not hasComments) - $ docSeq + addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "if" , appSep $ docForceSingleline ifExprDoc , appSep $ docLit $ Text.pack "then" @@ -502,29 +513,34 @@ layoutExpr lexpr@(L _ expr) = do -- else -- stuff -- note that this has par-spacing - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - ( docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docNonBottomSpacing + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc ] , docAddBaseY BrIndentRegular - $ docNonBottomSpacing $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ] + ) -- either -- if multi -- line @@ -542,62 +558,69 @@ layoutExpr lexpr@(L _ expr) = do -- else -- stuff -- note that this does _not_ have par-spacing - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - ( docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ]) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "then" + , docForceParSpacing thenExprDoc ] , docAddBaseY BrIndentRegular - $ docAlt - [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ]) - addAlternative - $ docSetBaseY - $ docLines - [ docAddBaseY maySpecialIndent - $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "else" + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc ] + ) + addAlternative $ docSetBaseY $ docLines + [ docAddBaseY maySpecialIndent $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" hasComments <- hasAnyCommentsBelow lexpr docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "if") - (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) + (layoutPatternBindFinal + Nothing + binderDoc + Nothing + clauseDocs + Nothing + hasComments + ) HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc1 <- docSharedWrapper layoutExpr exp1 -- We jump through some ugly hoops here to ensure proper sharing. hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds + mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds let ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = - case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x + ifIndentFreeElse x y = case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x -- this `docSetBaseAndIndent` might seem out of place (especially the -- Indent part; setBase is necessary due to the use of docLines below), -- but is here due to ghc-exactprint's DP handling of "let" in @@ -610,36 +633,35 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) - $ appSep $ docForceSingleline bindDoc + , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline + bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ] addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) + [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ bindDoc ] + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent bindDoc) + ] , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY expDoc1) + [ docSeq + [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse + docSetBaseAndIndent + docForceSingleline + expDoc1 ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) + ] ] - Just bindDocs@(_:_) -> runFilteredAlternative $ do + Just bindDocs@(_ : _) -> runFilteredAlternative $ do --either -- let -- a = b @@ -653,102 +675,91 @@ layoutExpr lexpr@(L _ expr) = do -- c = d -- in -- fooooooooooooooooooo - let noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular - $ docForceParSpacing expDoc1 - ] + let + noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines bindDocs) + , docSeq + [ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 ] + ] addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyLeft -> docLines noHangingBinds IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docSeq + IndentPolicyFree -> docLines + [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines bindDocs ] - , docSeq - [ appSep $ docLit $ Text.pack "in " - , docSetBaseY expDoc1 - ] + , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] ] - addAlternative - $ docLines + addAlternative $ docLines [ docNodeAnnKW lexpr (Just AnnLet) $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "in") - (docSetBaseY $ expDoc1) + $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) ] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1] HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of DoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) MDoExpr _ -> do stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x | case x of { ListComp -> True - ; MonadComp -> True - ; _ -> False } -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ docNodeAnnKW lexpr Nothing - $ appSep - $ docLit - $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq $ List.intersperse docCommaSep - $ docForceSingleline <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative $ - let - start = docCols ColListComp - [ docNodeAnnKW lexpr Nothing - $ appSep $ docLit $ Text.pack "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1:sM) = List.init stmtDocs - line1 = docCols ColListComp - [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> - docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + x + | case x of + ListComp -> True + MonadComp -> True + _ -> False + -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq + $ List.intersperse docCommaSep + $ docForceSingleline + <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative + $ let + start = docCols + ColListComp + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack + "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1 : sM) = List.init stmtDocs + line1 = + docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] _ -> do -- TODO unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_:_) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr + ExplicitList _ _ elems@(_ : _) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of FirstLastEmpty -> docSeq @@ -772,109 +783,106 @@ layoutExpr lexpr@(L _ expr) = do ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse + docCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) + ) ++ [docLit $ Text.pack "]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> - docCols ColList [docCommaSep, d] - lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> - docLit $ Text.pack "[]" - RecordCon _ lname fields -> - case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- fs - `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> docCols ColList [docCommaSep, d] + lineN = docCols + ColList + [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ExplicitList _ _ [] -> docLit $ Text.pack "[]" + RecordCon _ lname fields -> case fields of + HsRecFields fs Nothing -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + rFs <- + fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + let FieldOcc _ lnameF = fieldOcc + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ (lfield, lrdrNameToText lnameF, rFExpDoc) + recordExpression False indentPolicy lexpr nameDoc rFs + HsRecFields [] (Just (L _ 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " { .. }" + HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + fieldDocs <- + fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr fExpr return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr + recordExpression True indentPolicy lexpr nameDoc fieldDocs + _ -> unknownNodeError "RecordCon with puns" lexpr RecordUpd _ rExpr fields -> do rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- fields - `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFs <- + fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do rFExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr return $ case ambName of Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) recordExpression False indentPolicy lexpr rExprDoc rFs ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 - docSeq - [ appSep expDoc - , appSep $ docLit $ Text.pack "::" - , typDoc - ] - ArithSeq _ Nothing info -> - case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> - briDocByExactInlineOnly "ArithSeq" lexpr + docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] + ArithSeq _ Nothing info -> case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr HsBracket{} -> do -- TODO briDocByExactInlineOnly "HsBracket{}" lexpr @@ -887,11 +895,12 @@ layoutExpr lexpr@(L _ expr) = do HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do allocateNode $ BDFPlain (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]") + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]" + ) HsSpliceE{} -> do -- TODO briDocByExactInlineOnly "HsSpliceE{}" lexpr @@ -923,78 +932,79 @@ recordExpression -> IndentPolicy -> GenLocated SrcSpan lExpr -> ToBriDocM BriDocNumbered - -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))] + -> [ ( GenLocated SrcSpan name + , Text + , Maybe (ToBriDocM BriDocNumbered) + ) + ] -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = - docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = - docSeq -- this case might still be incomplete, and is probably not used +recordExpression False _ lexpr nameDoc [] = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack "}" + ] +recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do + [ docNodeAnnKW lexpr (Just AnnOpenC) + $ docSeq [nameDoc, docLit $ Text.pack "{"] + , docLit $ Text.pack " .. }" + ] +recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do let (rF1f, rF1n, rF1e) = rF1 runFilteredAlternative $ do -- container { fieldA = blub, fieldB = blub } - addAlternative - $ docSeq + addAlternative $ docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> - docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> - docWrapNode lfield $ docLit fieldStr + , docSeq $ List.intersperse docCommaSep $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr , if dotdot - then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator + then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] + else docSeparator , docLit $ Text.pack "}" ] -- hanging single-line fields -- container { fieldA = blub -- , fieldB = blub -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docSeq + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY $ docLines $ let - line1 = docCols ColRec + , docSetBaseY + $ docLines + $ let + line1 = docCols + ColRec [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit rF1n , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] - Nothing -> docEmpty + Just x -> docWrapNodeRest rF1f $ docSeq + [appSep $ docLit $ Text.pack "=", docForceSingleline x] + Nothing -> docEmpty ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x - ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec + [ docCommaSep + , appSep $ docLit fText + , case fDoc of + Just x -> + docSeq [appSep $ docLit $ Text.pack "=", docForceSingleline x] Nothing -> docEmpty - ] + ] dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] + in [line1] ++ lineR ++ [dotdotLine, lineN] ] -- non-hanging with expressions placed to the right of the names -- container @@ -1002,77 +1012,75 @@ recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do -- , fieldB = potentially -- multiline -- } - addAlternative - $ docSetParSpacing - $ docAddBaseY BrIndentRegular - $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing $ docLines $ let - line1 = docCols ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield - $ docCols ColRec + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docNodeAnnKW lexpr Nothing nameDoc) + (docNonBottomSpacing + $ docLines + $ let + line1 = docCols + ColRec + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> + docWrapNode lfield $ docCols + ColRec [ docCommaSep , appSep $ docLit fText , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq - [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq [ appSep $ docLit $ Text.pack "=" - , docForceParSpacing x - ] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty + Just x -> runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing x] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + Nothing -> docEmpty ] - dotdotLine = if dotdot - then docCols ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) - $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) + dotdotLine = if dotdot + then docCols + ColRec + [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep + , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." + ] + else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + lineN = docLit $ Text.pack "}" + in [line1] ++ lineR ++ [dotdotLine, lineN] + ) litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t _ -> error "litBriDoc: literal with no SourceText" overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 78c56e4..8684842 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -35,36 +35,40 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] IEThingWith _ x _ ns _ -> do hasComments <- orM - ( hasCommentsBetween lie AnnOpenP AnnCloseP + (hasCommentsBetween lie AnnOpenP AnnCloseP : hasAnyCommentsBelow x : map hasAnyCommentsBelow ns ) let sortedNs = List.sortOn wrappedNameToText ns runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] + $ docSeq + $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc sortedNs) ++ [docParenR] addAlternative $ docWrapNodeRest lie $ docAddBaseY BrIndentRegular - $ docPar - (layoutWrapped lie x) - (layoutItems (splitFirstLast sortedNs)) + $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) where nameDoc = docLit <=< lrdrNameToTextAnn . prepareName layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItems FirstLastEmpty = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] + , docParenR + ] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] + [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] + , docParenR + ] layoutItems (FirstLast n1 nMs nN) = docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + $ docLines + $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] ++ map layoutItem nMs - ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] + ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] + , docParenR + ] IEModuleContents _ n -> docSeq [ docLit $ Text.pack "module" , docSeparator @@ -73,7 +77,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n + L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEPattern n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "pattern " <> name @@ -90,33 +94,36 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs - :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] + :: SortItemsFlag + -> Located [LIE GhcPs] + -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] - let sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText - $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies + let + sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let + ieDocs = fmap layoutIE $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies ieCommaDocs <- docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] + FirstLastEmpty -> [] FirstLastSingleton ie -> [ie] FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] pure $ fmap pure ieCommaDocs -- returned shared nodes where mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] + mergeGroup [] = [] mergeGroup items@[_] = items - mergeGroup items = if + mergeGroup items = if | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items -- proper means that if it is a ThingWith, it does not contain a wildcard -- (because I don't know what a wildcard means if it is not already a -- IEThingAll). @@ -129,21 +136,22 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do isIEVar :: LIE GhcPs -> Bool isIEVar = \case L _ IEVar{} -> True - _ -> False + _ -> False thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{} ) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 ( L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder l1@(L _ IEVar{}) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 (L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) = L l - (IEThingWith x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) + (IEThingWith + x + wn + NoIEWildcard + (consItems1 ++ consItems2) + (fieldLbls1 ++ fieldLbls2) ) thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -162,9 +170,10 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered +layoutLLIEs + :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies + ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies runFilteredAlternative $ case ieDs of [] -> do @@ -174,14 +183,14 @@ layoutLLIEs enableSingleline shouldSort llies = do docParenR (ieDsH : ieDsT) -> do addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] + $ docSeq + $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) ++ [docParenR] addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT + $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT ++ [docParenR] -- | Returns a "fingerprint string", not a full text representation, nor even @@ -189,26 +198,27 @@ layoutLLIEs enableSingleline shouldSort llies = do -- Used for sorting, not for printing the formatter's output source code. wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n + L _ (IEName n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n + L _ (IEType n) -> lrdrNameToText n -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. -- Used for sorting, not for printing the formatter's output source code. lieToText :: LIE GhcPs -> Text lieToText = \case - L _ (IEVar _ wn ) -> wrappedNameToText wn - L _ (IEThingAbs _ wn ) -> wrappedNameToText wn - L _ (IEThingAll _ wn ) -> wrappedNameToText wn + L _ (IEVar _ wn) -> wrappedNameToText wn + L _ (IEThingAbs _ wn) -> wrappedNameToText wn + L _ (IEThingAll _ wn) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn -- TODO: These _may_ appear in exports! -- Need to check, and either put them at the top (for module) or do some -- other clever thing. L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" where moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) + moduleNameToText (L _ name) = + Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index d8ff3ff..fc17cde 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -30,111 +30,128 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered layoutImport importD = case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + importAsCol <- + mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let - compact = indentPolicy /= IndentPolicyFree + compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = - let qualifiedPart = if q /= NotQualified then length "qualified " else 0 - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal + let + qualifiedPart = if q /= NotQualified then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT + srcPart = case src of + IsBoot -> length "{-# SOURCE #-} " + NotBoot -> 0 + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength + asCost = length "as " + hidingParenCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" - , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } + , case src of + IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}" + NotBoot -> docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty - , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty + , if q /= NotQualified + then appSep $ docLit $ Text.pack "qualified" + else docEmpty , maybe docEmpty (appSep . docLit) pkgNameT ] indentName = if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = - indentName $ appSep $ docLit modNameT + modNameD = indentName $ appSep $ docLit modNameT hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = if hiding - then appSep $ docLit $ Text.pack "hiding" - else docEmpty + hidDoc = + if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of + bindingsD = case mllies of Nothing -> docEmpty Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docAlt - [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] - , let makeParIfHiding = if hiding + then docAlt + [ docSeq + [ hidDoc + , docForceSingleline $ layoutLLIEs True ShouldSortItems llies + ] + , let + makeParIfHiding = if hiding then docAddBaseY BrIndentRegular . docPar hidDoc else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar - (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - ( docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) + in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) + ] + else do + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq + [hidDoc, docParenLSep, docWrapNode llies docEmpty] + ) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + else docSeq + [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + [ hidDoc + , docParenLSep + , docForceSingleline ieD + , docSeparator + , docParenR + ] + addAlternative $ docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent + (BrIndentSpecial hidDocColDiff) + docParenR + ) + -- ..[hiding].( b + -- , b' + -- ) + (ieD : ieDs') -> docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] + ) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular $ - docPar (docSeq [importHead, asDoc]) bindingsD - ] - else - case masT of + then + let asDoc = maybe docEmpty makeAsDoc masT + in + docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular + $ docPar (docSeq [importHead, asDoc]) bindingsD + ] + else case masT of Just n -> if enoughRoom - then docLines - [ docSeq [importHead, asDoc], bindingsD] + then docLines [docSeq [importHead, asDoc], bindingsD] else docLines [importHead, asDoc, bindingsD] where enoughRoom = nameCost < importAsCol - asCost - asDoc = - docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n + asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) + $ makeAsDoc n Nothing -> if enoughRoom then docSeq [importHead, bindingsD] else docLines [importHead, bindingsD] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 73090ce..8de45d7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -25,7 +25,7 @@ import Language.Haskell.GHC.ExactPrint.Types layoutModule :: ToBriDoc' HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do + HsModule _ Nothing _ imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) @@ -36,10 +36,8 @@ layoutModule lmod@(L _ mod') = case mod' of -- groupify commentedImports `forM_` tellDebugMessShow -- sortedImports <- sortImports imports let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- mAsk - <&> _conf_layout - .> _lconfig_allowSingleLineExportList - .> confUnpack + allowSingleLineExportList <- + mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack -- the config should not prevent single-line layout when there is no -- export list let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les @@ -49,30 +47,26 @@ layoutModule lmod@(L _ mod') = case mod' of -- A pseudo node that serves merely to force documentation -- before the node , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ - docForceSingleline - $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative - $ docLines + addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + addAlternative $ docLines [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docSeq [ - docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) + (docSeq + [ docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docLit $ Text.pack "where" + ] + ) ] ] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] @@ -84,7 +78,7 @@ data CommentedImport instance Show CommentedImport where show = \case - EmptyLine -> "EmptyLine" + EmptyLine -> "EmptyLine" IndependentComment _ -> "IndependentComment" ImportStatement r -> "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show @@ -97,8 +91,9 @@ data ImportStatementRecord = ImportStatementRecord } instance Show ImportStatementRecord where - show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) + show r = + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) transformToCommentedImport :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] @@ -116,10 +111,11 @@ transformToCommentedImport is = do accumF accConnectedComm (annMay, decl) = case annMay of Nothing -> ( [] - , [ ImportStatement ImportStatementRecord { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } + , [ ImportStatement ImportStatementRecord + { commentsBefore = [] + , commentsAfter = [] + , importStatement = decl + } ] ) Just ann -> @@ -131,7 +127,7 @@ transformToCommentedImport is = do :: [(Comment, DeltaPos)] -> [(Comment, DeltaPos)] -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) + go acc [] = ([], acc, 0) go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs go acc ((c1, DP (y, x)) : xs) = @@ -148,8 +144,8 @@ transformToCommentedImport is = do , convertedIndependentComments ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm + { commentsBefore = beforeComments + , commentsAfter = accConnectedComm , importStatement = decl } ] @@ -163,14 +159,14 @@ sortCommentedImports = where unpackImports :: [CommentedImport] -> [CommentedImport] unpackImports xs = xs >>= \case - l@EmptyLine -> [l] + l@EmptyLine -> [l] l@IndependentComment{} -> [l] ImportStatement r -> map IndependentComment (commentsBefore r) ++ [ImportStatement r] mergeGroups :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] mergeGroups xs = xs >>= \case - Left x -> [x] + Left x -> [x] Right y -> ImportStatement <$> y sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups = @@ -180,25 +176,22 @@ sortCommentedImports = groupify cs = go [] cs where go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest + (l@EmptyLine : rest) -> Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] + (ImportStatement r : rest) -> go [r] rest + [] -> [] go acc = \case (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : Right (reverse acc) : go [] rest (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] + [] -> [Right (reverse acc)] commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered commentedImportsToDoc = \case EmptyLine -> docLitS "" IndependentComment c -> commentToDoc c - ImportStatement r -> - docSeq - ( layoutImport (importStatement r) - : map commentToDoc (commentsAfter r) - ) + ImportStatement r -> docSeq + (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) where commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index fd4025a..773d993 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -31,17 +31,15 @@ import Language.Haskell.Brittany.Internal.Types -- the different cases below. layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr - VarPat _ n -> - fmap Seq.singleton $ docLit $ lrdrNameToText n + VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n -- abc -> expr - LitPat _ lit -> - fmap Seq.singleton $ allocateNode $ litBriDoc lit + LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit -- 0 -> expr ParPat _ inner -> do -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" + left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" innerDocs <- colsWrapPat =<< layoutPat inner return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right @@ -67,10 +65,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of then return <$> docLit nameDoc else do x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList - $ sequence - $ spacifyDocs - $ fmap colsWrapPat argDocs + xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap + colsWrapPat + argDocs return $ x1 Seq.<| xR ConPat _ lname (InfixCon left right) -> do -- a :< b -> expr @@ -83,7 +80,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname @@ -96,37 +93,34 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of Seq.singleton <$> docSeq [ appSep $ docLit t , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep - $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName + , docSeq $ List.intersperse docCommaSep $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName , docSeparator , docLit $ Text.pack "}" ] ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do -- Abc { .. } -> expr let t = lrdrNameToText lname - Seq.singleton <$> docSeq - [ appSep $ docLit t - , docLit $ Text.pack "{..}" - ] - ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do + Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"] + ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) + | dotdoti == length fs -> do -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + let FieldOcc _ lnameF = fieldOcc + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return (lrdrNameToText lnameF, fExpDoc) + Seq.singleton <$> docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ fds >>= \case (fieldName, Just fieldDoc) -> [ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "=" @@ -134,13 +128,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docCommaSep ] (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] + , docLit $ Text.pack "..}" + ] TuplePat _ args boxity -> do -- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR + Boxed -> wrapPatListy args "()" docParenL docParenR Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep AsPat _ asName asPat -> do -- bind@nestedpat -> expr @@ -180,7 +174,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] + Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat @@ -189,9 +183,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList wrapPatPrepend - :: LPat GhcPs - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) + :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) wrapPatPrepend pat prepElem = do patDocs <- layoutPat pat case Seq.viewl patDocs of @@ -213,8 +205,5 @@ wrapPatListy elems both start end = do x1 Seq.:< rest -> do sDoc <- start eDoc <- end - rest' <- rest `forM` \bd -> docSeq - [ docCommaSep - , return bd - ] + rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd] return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 7f297fe..5ef19c7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -47,12 +47,12 @@ layoutStmt lstmt@(L _ stmt) = do ] ] LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree + let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" + Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [bindDoc] -> docAlt [ -- let bind = expr docCols @@ -62,9 +62,10 @@ layoutStmt lstmt@(L _ stmt) = do f = case indentPolicy of IndentPolicyFree -> docSetBaseAndIndent IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc + IndentPolicyMultiple + | indentFourPlus -> docSetBaseAndIndent + | otherwise -> docForceSingleline + in f $ return bindDoc ] , -- let -- bind = expr @@ -78,10 +79,11 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (isFree || indentFourPlus) $ docSeq [ appSep $ docLit $ Text.pack "let" - , let f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs + , let + f = if indentFourPlus + then docEnsureIndent BrIndentRegular + else docSetBaseAndIndent + in f $ docLines $ return <$> bindDocs ] -- let -- aaa = expra @@ -89,8 +91,9 @@ layoutStmt lstmt@(L _ stmt) = do -- ccc = exprc addAlternativeCond (not indentFourPlus) $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 208f6b4..1662ffb 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -24,76 +24,63 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsTyVar _ promoted name -> do t <- lrdrNameToTextAnnTypeEqualityIsSpecial name case promoted of - IsPromoted -> docSeq - [ docSeparator - , docTick - , docWrapNode name $ docLit t - ] + IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] NotPromoted -> docWrapNode name $ docLit t HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do let bndrs = getBinders hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs forallDoc = docAlt - [ let - open = docLit $ Text.pack "forall" - in docSeq ([open]++tyVarDocLineList) + [ let open = docLit $ Text.pack "forall" + in docSeq ([open] ++ tyVarDocLineList) , docPar - (docLit (Text.pack "forall")) - (docLines - $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ]) + (docLit (Text.pack "forall")) + (docLines $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" + ] + ) ] contextDoc = case cntxtDocs of [] -> docLit $ Text.pack "()" [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs - ] + open = docCols + ColTyOpPrefix + [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) cntxtDoc - ] + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] in docPar open $ docLines $ list ++ [close] ] docAlt -- :: forall a b c . (Foo a b c) => a b -> c [ docSeq [ if null bndrs - then docEmpty - else let + then docEmpty + else + let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) + in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) , docForceSingleline contextDoc , docLit $ Text.pack " => " , docForceSingleline typeDoc @@ -103,75 +90,74 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - forallDoc - ( docLines - [ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) - $ contextDoc - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] + forallDoc + (docLines + [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) $ contextDoc ] - ) + , docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] + ] + ) ] HsForAllTy _ hsf typ2 -> do let bndrs = getBinders hsf typeDoc <- layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs docAlt -- forall x . x [ docSeq [ if null bndrs - then docEmpty - else let + then docEmpty + else + let open = docLit $ Text.pack "forall" close = docLit $ Text.pack " . " - in docSeq ([open]++tyVarDocLineList++[close]) + in docSeq ([open] ++ tyVarDocLineList ++ [close]) , docForceSingleline $ return $ typeDoc ] -- :: forall x -- . x , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ) -- :: forall -- (x :: *) -- . x , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular - $ docLines - [ docCols ColTyOpPrefix - [ docParenLSep - , docLit tname - ] - , docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , doc - ] - , docLit $ Text.pack ")" - ] - ) - ++[ docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> + docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" ] - ] ) + ++ [ docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , maybeForceML $ return typeDoc + ] + ] + ) ] HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do typeDoc <- docSharedWrapper layoutType typ1 @@ -182,29 +168,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of [x] -> x _ -> docAlt [ let - open = docLit $ Text.pack "(" + open = docLit $ Text.pack "(" close = docLit $ Text.pack ")" - list = List.intersperse docCommaSep - $ docForceSingleline <$> cntxtDocs - in docSeq ([open]++list++[close]) + list = + List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs + in docSeq ([open] ++ list ++ [close]) , let - open = docCols ColTyOpPrefix - [ docParenLSep - , docAddBaseY (BrIndentSpecial 2) - $ head cntxtDocs - ] + open = docCols + ColTyOpPrefix + [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> - docCols ColTyOpPrefix - [ docCommaSep - , docAddBaseY (BrIndentSpecial 2) - $ cntxtDoc - ] + list = List.tail cntxtDocs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] in docPar open $ docLines $ list ++ [close] ] - let maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id docAlt -- (Foo a b c) => a b -> c [ docSeq @@ -216,37 +198,39 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- => a b -- -> c , docPar - (docForceSingleline contextDoc) - ( docCols ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) + (docForceSingleline contextDoc) + (docCols + ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) ] HsFunTy _ _ typ1 typ2 -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc2 <- docSharedWrapper layoutType typ2 - let maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id + let + maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id hasComments <- hasAnyCommentsBelow ltype - docAlt $ - [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 + docAlt + $ [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 + ] + | not hasComments ] - | not hasComments - ] ++ - [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) - $ maybeForceML typeDoc2 - ] - ) - ] + ++ [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 + ] + ) + ] HsParTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt @@ -256,24 +240,28 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack ")" ] , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack ")") + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack ")") ] HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 - final -> (final, list) + let + gather + :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 + final -> (final, list) let (typHead, typRest) = gather [typ2] typ1 docHead <- docSharedWrapper layoutType typHead docRest <- docSharedWrapper layoutType `mapM` typRest docAlt [ docSeq - $ docForceSingleline docHead : (docRest >>= \d -> - [ docSeparator, docForceSingleline d ]) + $ docForceSingleline docHead + : (docRest >>= \d -> [docSeparator, docForceSingleline d]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] HsAppTy _ typ1 typ2 -> do @@ -281,13 +269,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc2 <- docSharedWrapper layoutType typ2 docAlt [ docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docForceSingleline typeDoc2 - ] - , docPar - typeDoc1 - (docEnsureIndent BrIndentRegular typeDoc2) + [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2] + , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) ] HsListTy _ typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 @@ -298,51 +281,61 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of , docLit $ Text.pack "]" ] , docPar - ( docCols ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ]) - (docLit $ Text.pack "]") + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (docLit $ Text.pack "]") ] HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where - unboxed = if null typs then error "brittany internal error: unboxed unit" - else unboxedL + unboxed = if null typs + then error "brittany internal error: unboxed unit" + else unboxedL simple = if null typs then unitL else simpleL unitL = docLit $ Text.pack "()" simpleL = do docs <- docSharedWrapper layoutType `mapM` typs - let end = docLit $ Text.pack ")" - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) + let + end = docLit $ Text.pack ")" + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt - [ docSeq $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] + [ docSeq + $ [docLit $ Text.pack "("] + ++ docWrapNodeRest ltype commaDocs + ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) + in + docPar + (docAddBaseY (BrIndentSpecial 2) $ line1) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs - let start = docParenHashLSep - end = docParenHashRSep + let + start = docParenHashLSep + end = docParenHashRSep docAlt - [ docSeq $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] + [ docSeq + $ [start] + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) + ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] - lines = List.tail docs <&> \d -> - docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] + lines = + List.tail docs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) (docLines $ lines ++ [end]) @@ -411,20 +404,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of typeDoc1 <- docSharedWrapper layoutType typ1 docAlt [ docSeq - [ docWrapNodeRest ltype - $ docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + [ docWrapNodeRest ltype $ docLit $ Text.pack + ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") , docForceSingleline typeDoc1 ] , docPar - ( docLit - $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) - ) - (docCols ColTyOpPrefix - [ docWrapNodeRest ltype - $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ]) + (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) + (docCols + ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ] + ) ] -- TODO: test KindSig HsKindSig _ typ1 kind1 -> do @@ -465,7 +456,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] else docPar typeDoc1 - ( docCols + (docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) kindDoc1 @@ -536,7 +527,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq - $ [docLit $ Text.pack "'["] + $ [docLit $ Text.pack "'["] ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"] , case splitFirstLast typDocs of @@ -561,19 +552,23 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] FirstLast e1 ems eN -> runFilteredAlternative $ do addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse + specialCommaSep + (docForceSingleline + <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) + ) ++ [docLit $ Text.pack " ]"] - addAlternative $ - let - start = docCols ColList - [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> - docCols ColList [specialCommaSep, d] - lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] + lineN = docCols + ColList + [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype @@ -584,8 +579,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy NoSourceText _ -> error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> - docLit $ Text.pack "_" + HsWildCardTy _ -> docLit $ Text.pack "_" HsSumTy{} -> -- TODO briDocByExactInlineOnly "HsSumTy{}" ltype HsStarTy _ isUnicode -> do @@ -598,14 +592,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of k <- docSharedWrapper layoutType kind docAlt [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar - t - (docSeq [docLit $ Text.pack "@", k ]) + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar t (docSeq [docLit $ Text.pack "@", k]) ] layoutTyVarBndrs diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs index 8b09fa1..c1bd60a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -18,9 +18,10 @@ obfuscate input = do let predi x = isAlphaNum x || x `elem` "_'" let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x + let + exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x let filtered = filter exceptionFilter idents mappings <- fmap Map.fromList $ filtered `forM` \x -> do r <- createAlias x @@ -72,14 +73,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] createAlias :: String -> IO String createAlias xs = go NoHint xs where - go _hint "" = pure "" - go hint (c : cr) = do + go _hint "" = pure "" + go hint (c : cr) = do c' <- case hint of VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr pure (c' : cr') diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs index d2527e9..394a78d 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -27,12 +27,12 @@ instance Alternative Strict.Maybe where x <|> Strict.Nothing = x _ <|> x = x -traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +traceFunctionWith + :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) traceFunctionWith name s1 s2 f x = trace traceStr y where y = f x - traceStr = - name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y + traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y (<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) = flip (<$!>) @@ -48,10 +48,10 @@ printErr = putStrErrLn . show errorIf :: Bool -> a -> a errorIf False = id -errorIf True = error "errorIf" +errorIf True = error "errorIf" errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id +errorIfNote Nothing = id errorIfNote (Just x) = error x (<&>) :: Functor f => f a -> (a -> b) -> f b diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 0e5b85f..5cca1ca 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -30,7 +30,7 @@ data AltCurPos = AltCurPos , _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_forceMLFlag :: AltLineModeState } - deriving (Show) + deriving Show data AltLineModeState = AltLineModeStateNone @@ -41,17 +41,18 @@ data AltLineModeState deriving (Show) altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = + AltLineModeStateContradiction altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction +altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of @@ -76,7 +77,7 @@ transformAlts = . Memo.startEvalMemoT . fmap unwrapBriDocNumbered . rec - where + where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) -- transWrap :: BriDoc -> BriDocNumbered @@ -114,224 +115,244 @@ transformAlts = - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered - rec bdX@(brDcId, brDc) = do - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> - reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> - reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp - { _acp_indent = ind - , _acp_indentPrep = 0 - } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' - { _acp_line = ind - , _acp_indent = ind - } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( hasSpace1 lconf acp vs && lineCheck vs, bd)) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ]) - $ zip [1..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let lineCheck (VerticalSpacing _ p _) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk - let options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - ( any (hasSpace2 lconf acp) vs - && any lineCheck vs, bd)) - let checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do - mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l:lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp - { _acp_line = ind - , _acp_indent = ind - } - rec x - return $ reWrap $ BDFLines (l':lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + rec + :: BriDocNumbered + -> Memo.MemoT + Int + [VerticalSpacing] + (MultiRWSS.MultiRWS r w (AltCurPos ': s)) + BriDocNumbered + rec bdX@(brDcId, brDc) = do + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- + mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let + indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd + mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } + sameLine' <- rec sameLine + mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let + lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + -- TODO: use COMPLETE pragma instead? + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (hasSpace1 lconf acp vs && lineCheck vs, bd) + ) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust + (\(_i :: Int, (b, x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ] + ) + $ zip [1 ..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let + lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk + let + options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) + ) + let + checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) + rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp + { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp + } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFPlain{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet + $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l : lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } + rec x + return $ reWrap $ BDFLines (l' : lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAdd <- fixIndentationForMultiple acp indent + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> + reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing _ bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess + $ "transformAlts: BDFDEBUG " + ++ s + ++ " (node-id=" + ++ show brDcId + ++ "): acp=" + ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple + :: ( MonadMultiReader Config m + , MonadMultiState AltCurPos m + , MonadMultiWriter (Seq String) m + ) + => BriDocNumbered + -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 + :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + + sameLine + <= confUnpack (_lconfig_cols lconf) + && indent + + indentPrep + + par + <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) getSpacing :: forall m @@ -348,10 +369,11 @@ getSpacing !bridoc = rec bridoc -- BDWrapAnnKey _annKey bd -> rec bd BDFEmpty -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> - return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False - BDFSeq list -> - sumVs <$> rec `mapM` list + BDFLit t -> return $ LineModeValid $ VerticalSpacing + (Text.length t) + VerticalSpacingParNone + False + BDFSeq list -> sumVs <$> rec `mapM` list BDFCols _sig list -> sumVs <$> rec `mapM` list BDFSeparator -> return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False @@ -359,23 +381,23 @@ getSpacing !bridoc = rec bridoc mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) + BrIndentSpecial j -> i + j } BDFBaseYPushCur bd -> do mVs <- rec bd @@ -385,11 +407,13 @@ getSpacing !bridoc = rec bridoc -- the reason is that we really want to _keep_ it Just if it is -- just so we properly communicate the is-multiline fact. -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) , _vs_paragraph = VerticalSpacingParSome 0 } BDFBaseYPop bd -> rec bd @@ -403,86 +427,104 @@ getSpacing !bridoc = rec bridoc | VerticalSpacing lsp mPsp _ <- mVs , indSp <- mIndSp , lineMax <- getMaxVS $ mIndSp - , let pspResult = case mPsp of - VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax - , let parFlagResult = mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp + , let + pspResult = case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp lineMax + , let + parFlagResult = + mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp ] BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> do + BDFAlt (alt : _) -> rec alt + BDFForceMultiline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> LineModeInvalid - _ -> mVs + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case VerticalSpacingParNone -> mVs - _ -> LineModeInvalid + _ -> LineModeInvalid BDFForwardLineMode bd -> rec bd BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return - $ LineModeValid - $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_:_) -> do + BDFLines [] -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_ : _) -> do lSps <- rec `mapM` ls - let (mVs:_) = lSps -- separated into let to avoid MonadFail - return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] + let (mVs : _) = lSps -- separated into let to avoid MonadFail + return + $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] BDFEnsureIndent indent bd -> do mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf BDFNonBottomSpacing b bd -> do mVs <- rec bd - return - $ mVs - <|> LineModeValid - (VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) + return $ mVs <|> LineModeValid + (VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } BDFForceParSpacing bd -> do mVs <- rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] BDFDebug s bd -> do r <- rec bd - tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r + tellDebugMess + $ "getSpacing: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): mVs=" + ++ show r return r return result - maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs = foldl' - (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - VerticalSpacing (max x1 y1) (case (x2, y2) of + (liftM2 + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> @@ -492,9 +534,14 @@ getSpacing !bridoc = rec bridoc (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> VerticalSpacingParAlways $ max i j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) False)) + VerticalSpacingParSome $ max x y + ) + False + ) + ) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs + :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing sumVs sps = foldl' (liftM2 go) initial sps where go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing @@ -503,18 +550,19 @@ getSpacing !bridoc = rec bridoc (x, VerticalSpacingParNone) -> x (VerticalSpacingParNone, x) -> x (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j + VerticalSpacingParAlways $ i + j (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y) + VerticalSpacingParSome $ x + y + ) x3 singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False + singleline _ = False isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False + isPar _ = False parFlag = case sps of [] -> True _ -> all singleline (List.init sps) && isPar (List.last sps) @@ -534,374 +582,380 @@ getSpacings -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where + where -- when we do `take K . filter someCondition` on a list of spacings, we -- need to first (also) limit the size of the input list, otherwise a -- _large_ input with a similarly _large_ prefix not passing our filtering -- process could lead to exponential runtime behaviour. -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3*limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let hasOkColCount (VerticalSpacing lsp psp _) = - lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let specialCompare vs1 vs2 = - if ( (_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let allowHangingQuasiQuotes = - config - & _conf_layout - & _lconfig_allowHangingQuasiQuotes - & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> - fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFSeparator -> - return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> i + ( confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit - $ [ (x,y) - | x<-mVss - , y<-indSps - ] - return $ mVsIndSp <&> - \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp) - ( mPsp == VerticalSpacingParNone - && _vs_paragraph indSp == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> - return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1 ] -> VerticalSpacing - (Text.length t1) - VerticalSpacingParNone - False - (t1 : _) -> VerticalSpacing - (Text.length t1) - (VerticalSpacingParAlways 0) - True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_:_) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let worbled = fmap reverse - $ sequence - $ reverse - $ lSpss - sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - sumF [] = error $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then [VerticalSpacing - 0 - (if b then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) - return r - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3 * limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let + hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let + specialCompare vs1 vs2 = + if ((_vs_sameLine vs1 == _vs_sameLine vs2) + && (_vs_parFlag vs1 == _vs_parFlag vs2) + ) + then case (_vs_paragraph vs1, _vs_paragraph vs2) of + (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> + if i1 < i2 then Smaller else Bigger + (p1, p2) -> if p1 == p2 then Smaller else Unequal + else Unequal + let + allowHangingQuasiQuotes = + config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack + let -- this is like List.nub, with one difference: if two elements + -- are unequal only in _vs_paragraph, with both ParAlways, we + -- treat them like equals and replace the first occurence with the + -- smallest member of this "equal group". + specialNub :: [VerticalSpacing] -> [VerticalSpacing] + specialNub [] = [] + specialNub (x1 : xr) = case go x1 xr of + (r, xs') -> r : specialNub xs' + where + go y1 [] = (y1, []) + go y1 (y2 : yr) = case specialCompare y1 y2 of + Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') + Smaller -> go y1 yr + Bigger -> go y2 yr + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = + take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . specialNub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list + BDFSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> + VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + + (confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> + i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max + (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i + ) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] + return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y) - False) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i+j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp + ) + (mPsp + == VerticalSpacingParNone + && _vs_paragraph indSp + == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFPlain t -> return + [ case Text.lines t of + [] -> VerticalSpacing 0 VerticalSpacingParNone False + [t1] -> + VerticalSpacing (Text.length t1) VerticalSpacingParNone False + (t1 : _) -> + VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True + | allowHangingQuasiQuotes + ] + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_ : _) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- map filterAndLimit <$> rec `mapM` ls + let + worbled = fmap reverse $ sequence $ reverse $ lSpss + sumF lSps@(lSp1 : _) = + VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False + sumF [] = + error + $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let + addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> + confUnpack $ _lconfig_indentAmount $ _conf_layout $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. + mVs <- rec bd + return $ if null mVs + then + [ VerticalSpacing + 0 + (if b + then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] + else mVs <&> \vs -> vs + { _vs_sameLine = min colMax (_vs_sameLine vs) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return + $ [ vs + | vs <- mVs + , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone + ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess + $ "getSpacings: BDFDebug " + ++ show s + ++ " (node-id=" + ++ show brDcId + ++ "): vs=" + ++ show (take 9 r) + return r + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y + ) + False + ) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i + j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y + ) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i fixIndentationForMultiple :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int fixIndentationForMultiple acp indent = do indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i + let + indAddRaw = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i -- for IndentPolicyMultiple, we restrict the amount of added -- indentation in such a manner that we end up on a multiple of the -- base indentation. indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack pure $ if indPolicy == IndentPolicyMultiple then - let indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 + let + indAddMultiple1 = + indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) + indAddMultiple2 = if indAddMultiple1 <= 0 + then indAddMultiple1 + indAmount + else indAddMultiple1 + in indAddMultiple2 else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 3dcdb46..0d2231e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -16,118 +16,147 @@ transformSimplifyColumns = Uniplate.rewrite $ \case -- BDWrapAnnKey annKey $ transformSimplify bd BDEmpty -> Nothing BDLit{} -> Nothing - BDSeq list | any (\case BDSeq{} -> True - BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) - | all (\case BDSeparator -> True; _ -> False) rest -> - Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) - BDLines lines | any (\case BDLines{} -> True - BDEmpty{} -> True - _ -> False) lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDSeq list + | any + (\case + BDSeq{} -> True + BDEmpty{} -> True + _ -> False + ) + list + -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_ : _) : rest) + | all + (\case + BDSeparator -> True + _ -> False + ) + rest + -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)]) + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l x -> [x] -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) -- post floating in BDAnnotationRest annKey1 (BDSeq list) -> Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] -- ensureIndent float-in -- not sure if the following rule is necessary; tests currently are -- unaffected. -- BDEnsureIndent indent (BDLines lines) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines -- matching col special transformation - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_:_) - | BDLines lines@(_:_:_) <- List.last cols1 + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_ : _) + | BDLines lines@(_ : _ : _) <- List.last cols1 , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) - | sig1==sig2 -> - Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) + | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) - | BDCols sig1 _ <- List.last lines1 - , sig1==sig2 -> - Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) + | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just + $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- | sig1==sig2 -> -- Just $ BDPar -- ind1 -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 (List.init cols ++ [line]) + BDCols sig1 cols + | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 + -> Just + $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] + BDCols sig1 cols + | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1 == sig2 + -> Just $ BDLines + [ BDCols sig1 + $ List.init cols + ++ [BDPar ind line (BDLines $ List.init lines)] , BDCols sig2 cols2 ] - BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1==sig2 -> - Just $ BDLines - [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] - , BDCols sig2 cols2 - ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing BDForceSingleline{} -> Nothing BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing + BDExternal{} -> Nothing + BDPlain{} -> Nothing + BDLines{} -> Nothing BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing + BDDebug{} -> Nothing BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 5ba0ce5..919decf 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -14,10 +14,11 @@ import Language.Haskell.Brittany.Internal.Utils -- note that this is not total, and cannot be with that exact signature. mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = + BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" transformSimplifyFloating :: BriDoc -> BriDoc @@ -27,169 +28,186 @@ transformSimplifyFloating = stepBO .> stepFull -- better complexity. -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> - Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_:_)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> - Just x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> - Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> - Just $ x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> - Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> - Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDLines (l:lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) - BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_ : _)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + BDAddBaseY BrIndentNone x -> Just x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDAddBaseY ind x) + BDAddBaseY ind (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + BDAddBaseY BrIndentNone x -> Just $ x + -- AddIndent floats into Lines. + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDLines (l : lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) + BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just + $ BDSeq + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just + $ BDLines + $ List.init list + ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just + $ BDCols sig + $ List.init cols + ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 648e7c7..613c5f0 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -27,15 +27,17 @@ transformSimplifyIndent = Uniplate.rewrite $ \case -- [ BDAddBaseY ind x -- , BDEnsureIndent ind indented -- ] - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> - Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l - x -> [x] + x -> [x] BDLines [l] -> Just l BDAddBaseY i (BDAnnotationPrior k x) -> Just $ BDAnnotationPrior k (BDAddBaseY i x) @@ -49,4 +51,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY _ lit@BDLit{} -> Just lit - _ -> Nothing + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 2d1abf1..6fe374a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -21,25 +21,28 @@ transformSimplifyPar = transformUp $ \case BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines | any ( \case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs + BDLines lines + | any + (\case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines + -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs where go = (=<<) $ \case BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x -- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- BDPar BrIndentNone line indented -> -- Just $ BDLines [line, indented] BDEnsureIndent BrIndentNone x -> x - x -> x + x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index 38f9123..b62028f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -61,24 +61,26 @@ instance (Num a, Ord a) => Semigroup (Max a) where (<>) = Data.Coerce.coerce (max :: a -> a -> a) instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 + mempty = Max 0 mappend = (<>) newtype ShowIsId = ShowIsId String deriving Data -instance Show ShowIsId where show (ShowIsId x) = x +instance Show ShowIsId where + show (ShowIsId x) = x -data A x = A ShowIsId x deriving Data +data A x = A ShowIsId x + deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -86,18 +88,22 @@ customLayouterF anns layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter + srcSpan ss = + simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" ++ showOutputable ss ++ "}" + $ "{" + ++ showOutputable ss + ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where @@ -109,12 +115,12 @@ customLayouterF anns layoutF = customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -122,14 +128,15 @@ customLayouterNoAnnsF layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + occName = + simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter @@ -193,12 +200,11 @@ traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () -tellDebugMess :: MonadMultiWriter - (Seq String) m => String -> m () +tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s -tellDebugMessShow :: forall a m . (MonadMultiWriter - (Seq String) m, Show a) => a -> m () +tellDebugMessShow + :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. @@ -213,29 +219,28 @@ briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) +annsDoc = + printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1:aR) = case fn a1 of - Left b -> (b : bs, cs) +breakEither _ [] = ([], []) +breakEither fn (a1 : aR) = case fn a1 of + Left b -> (b : bs, cs) Right c -> (bs, c : cs) - where - (bs, cs) = breakEither fn aR + where (bs, cs) = breakEither fn aR spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) - where - (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) +spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) + where (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) data FirstLastView a = FirstLastEmpty @@ -245,7 +250,7 @@ data FirstLastView a splitFirstLast :: [a] -> FirstLastView a splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) +splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) -- TODO: move to uniplate upstream? -- aka `transform` @@ -264,7 +269,7 @@ lines' :: String -> [String] lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] - (s1, (_:r)) -> s1 : lines' r + (s1, (_ : r)) -> s1 : lines' r absurdExt :: HsExtension.NoExtCon -> a absurdExt = HsExtension.noExtCon diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index ca9fc7b..e599fc2 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -105,7 +105,7 @@ helpDoc = PP.vcat $ List.intersperse ] , parDoc $ "See https://github.com/lspitzner/brittany" , parDoc - $ "Please report bugs at" + $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" ] @@ -142,15 +142,16 @@ mainCmdParser helpDesc = do addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser + configPaths <- addFlagStringParams + "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] @@ -176,7 +177,7 @@ mainCmdParser helpDesc = do "" ["write-mode"] "(display|inplace)" - ( flagHelp + (flagHelp (PP.vcat [ PP.text "display: output for any input(s) goes to stdout" , PP.text "inplace: override respective input file (without backup!)" @@ -206,11 +207,12 @@ mainCmdParser helpDesc = do $ ppHelpShallow helpDesc System.Exit.exitSuccess - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths + let + inputPaths = if null inputParams then [Nothing] else map Just inputParams + let + outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths configsToLoad <- liftIO $ if null configPaths then @@ -225,14 +227,15 @@ mainCmdParser helpDesc = do ) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x + Just x -> return x when (config & _conf_debug & _dconf_dump_config & confUnpack) $ trace (showConfigYaml config) $ return () - results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths + results <- zipWithM + (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths if checkMode then when (Changes `elem` (Data.Either.rights results)) @@ -268,51 +271,57 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = -- amount of slight differences: This module is a bit more verbose, and -- it tries to use the full-blown `parseModule` function which supports -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack -- the flag will do the following: insert a marker string -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- "#include" before processing (parsing) input; and remove that marker -- string from the transformation output. -- The flag is intentionally misspelled to prevent clashing with -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + let + hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let + exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False + let + cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False (parseResult, originalContents) <- case inputPathM of Nothing -> do -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id + let + hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let + hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id inputString <- liftIO System.IO.getContents - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) + parseRes <- liftIO $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) return (parseRes, Text.pack inputString) Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc + parseRes <- parseModule ghcOptions p cppCheckFunc inputText <- Text.IO.readFile p -- The above means we read the file twice, but the -- GHC API does not really expose the source it @@ -343,8 +352,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () - let disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack + let + disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack (errsWarns, outSText, hasChanges) <- do if | disableFormatting -> do @@ -353,46 +363,52 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let r = Text.pack $ ExactPrint.exactPrint parsedSource anns pure ([], r, r /= originalContents) | otherwise -> do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let + omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck then return $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - else outRaw + else liftIO $ pPrintModuleAndCheck + moduleConf + perItemConf + anns + parsedSource + let + hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let + out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ hackF + <$> TextL.splitOn (TextL.pack "\n") outRaw + else outRaw out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out pure $ (ews, out', out' /= originalContents) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 + let + customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 unless (null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns + let + groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns groupedErrsWarns `forM_` \case (ErrorOutputCheck{} : _) -> do putErrorLn - $ "ERROR: brittany pretty printer" + $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." (ErrorInput str : _) -> do putErrorLn $ "ERROR: parse error: " ++ str @@ -403,7 +419,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = ErrorUnknownNode str ast@(L loc _) -> do putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) when - ( config + (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack @@ -417,17 +433,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = putErrorLn $ "WARNINGS:" warns `forM_` \case LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" unused@(ErrorUnusedComment{} : _) -> do putErrorLn - $ "Error: detected unprocessed comments." + $ "Error: detected unprocessed comments." ++ " The transformation output will most likely" ++ " not contain some of the comments" ++ " present in the input haskell source file." putErrorLn $ "Affected are the following comments:" unused `forM_` \case ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" + _ -> error "cannot happen (TM)" (ErrorMacroConfig err input : _) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err @@ -438,8 +454,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = let hasErrors = if config & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) outputOnErrs = config & _conf_errorHandling @@ -454,10 +470,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = $ addTraceSep (_conf_debug config) $ case outputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges + Just p -> liftIO $ do + let + isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText when (checkMode && hasChanges) $ case inputPathM of @@ -469,15 +486,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = where addTraceSep conf = if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] then trace "----" else id