From b03996e401cb9f67a094213dcaec9edad4e2e384 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 3 Sep 2016 23:02:32 +0200 Subject: [PATCH] Apply brittany on parts of its source; Add comments --- src-brittany/Main.hs | 4 +- src-unittests/AsymptoticPerfTests.hs | 27 +- src-unittests/TestUtils.hs | 42 +- src/Language/Haskell/Brittany.hs | 96 ++-- src/Language/Haskell/Brittany/BriLayouter.hs | 230 +++++---- src/Language/Haskell/Brittany/Config.hs | 76 +-- src/Language/Haskell/Brittany/Config/Types.hs | 62 +-- .../Haskell/Brittany/ExactPrintUtils.hs | 53 +- src/Language/Haskell/Brittany/LayoutBasics.hs | 430 ++++++++-------- .../Haskell/Brittany/Layouters/Decl.hs | 457 ++++++++++-------- .../Haskell/Brittany/Layouters/Expr.hs | 26 +- .../Haskell/Brittany/Layouters/Stmt.hs | 37 +- src/Language/Haskell/Brittany/Types.hs | 119 ++--- src/Language/Haskell/Brittany/Utils.hs | 158 +++--- 14 files changed, 977 insertions(+), 840 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 4e79cb7..57399aa 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -225,11 +225,11 @@ readConfigs cmdlineConfig configPaths = do userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany" let defUserConfigPath = userBritPath FilePath. "config.yaml" merged <- case configPaths of - [] -> do + [] -> do liftIO $ Directory.createDirectoryIfMissing False userBritPath return cmdlineConfig >>= readMergePersConfig defLocalConfigPath False - >>= readMergePersConfig defUserConfigPath True + >>= readMergePersConfig defUserConfigPath True -- TODO: ensure that paths exist ? paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) (return cmdlineConfig) diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs index b39a358..98bc45f 100644 --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -21,14 +21,23 @@ import TestUtils asymptoticPerfTest :: Spec asymptoticPerfTest = do - it "1000 do statements" $ roundTripEqualWithTimeout 1000000 $ - ( Text.pack "func = do\n") + it "1000 do statements" + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = do\n") <> Text.replicate 1000 (Text.pack " statement\n") - it "1000 do nestings" $ roundTripEqualWithTimeout 4000000 $ - ( Text.pack "func = ") - <> mconcat ([0..999] <&> \(i::Int) -> (Text.replicate (2*i) (Text.pack " ") <> Text.pack "do\n")) - <> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n" - <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" - it "1000 AppOps" $ roundTripEqualWithTimeout 1000000 $ - ( Text.pack "func = expr") + it "1000 do nestings" + $ roundTripEqualWithTimeout 4000000 + $ (Text.pack "func = ") + <> mconcat + ( [0 .. 999] + <&> \(i :: Int) -> + (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") + ) + <> Text.replicate 2000 (Text.pack " ") + <> Text.pack "return\n" + <> Text.replicate 2002 (Text.pack " ") + <> Text.pack "()" + it "1000 AppOps" + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = expr") <> Text.replicate 200 (Text.pack "\n . expr") --TODO diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 482a25f..0024c41 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -21,15 +21,17 @@ import Data.Coerce ( coerce ) roundTripEqual :: Text -> Expectation -roundTripEqual t = fmap (fmap PPTextWrapper) (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) +roundTripEqual t = + fmap (fmap PPTextWrapper) + (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout time t = - timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust) - where - action = fmap (fmap PPTextWrapper) - (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) + timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) + where + action = fmap (fmap PPTextWrapper) + (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) newtype PPTextWrapper = PPTextWrapper Text deriving Eq @@ -39,19 +41,19 @@ instance Show PPTextWrapper where defaultTestConfig :: Config defaultTestConfig = Config - { _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 - , _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously - } - , _conf_errorHandling = _conf_errorHandling staticDefaultConfig - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } + { _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously } + , _conf_errorHandling = _conf_errorHandling staticDefaultConfig + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] + } + } diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index a190cff..7bacd59 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -59,8 +59,9 @@ pPrintModule -> GHC.ParsedSource -> ([LayoutError], TextL.Text) pPrintModule conf anns parsedModule = - let ((out, errs), debugStrings) - = runIdentity + let + ((out, errs), debugStrings) = + runIdentity $ MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW @@ -68,13 +69,18 @@ pPrintModule conf anns parsedModule = $ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiReader conf $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns + 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) + 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 -> @@ -101,27 +107,25 @@ pPrintModuleAndCheck conf anns parsedModule = do -- used for testing mostly, currently. -parsePrintModule - :: Config - -> String - -> Text - -> IO (Either String Text) +parsePrintModule :: Config -> String -> Text -> IO (Either String Text) parsePrintModule conf filename input = do let inputStr = Text.unpack input parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of - Left (_, s) -> return $ Left $ "parsing error: " ++ s + Left (_ , s ) -> return $ Left $ "parsing error: " ++ s Right (anns, parsedModule) -> do (errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule return $ if null errs then Right $ TextL.toStrict $ ltext else - let errStrs = errs <&> \case - LayoutErrorUnusedComment str -> str - LayoutWarning str -> str - LayoutErrorUnknownNode str _ -> str - LayoutErrorOutputCheck -> "Output is not syntactically valid." - in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs + let + errStrs = errs <&> \case + LayoutErrorUnusedComment str -> str + LayoutWarning str -> str + LayoutErrorUnknownNode str _ -> str + LayoutErrorOutputCheck -> "Output is not syntactically valid." + in + Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- this approach would for with there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally @@ -166,40 +170,40 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of Nothing -> (anns, []) Just mAnn -> - let - modAnnsDp = ExactPrint.Types.annsDP mAnn - isWhere (ExactPrint.Types.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.Types.G AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post) = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i, Nothing) -> List.splitAt (i+1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i, Just j) -> List.splitAt (min (i+1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.Types.annsDP = pre } - anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns - in (anns', post) + let modAnnsDp = ExactPrint.Types.annsDP mAnn + isWhere (ExactPrint.Types.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.Types.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post) = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + mAnn' = mAnn { ExactPrint.Types.annsDP = pre } + anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns + in (anns', post) MultiRWSS.withMultiReader anns' $ processDefault emptyModule decls `forM_` ppDecl - let - finalComments = filter (fst .> \case ExactPrint.Types.AnnComment{} -> True - _ -> False) - post + let finalComments = filter ( fst .> \case + ExactPrint.Types.AnnComment{} -> True + _ -> False + ) + post post `forM_` \case (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr - (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX,eofY))) -> + (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) -> let folder acc (kw, ExactPrint.Types.DP (x, _)) = case kw of ExactPrint.Types.AnnComment cm | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm -> acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span _ -> acc + x cmX = foldl' folder 0 finalComments - in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY) + in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY) _ -> return () withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM () @@ -229,15 +233,15 @@ ppDecl d@(L loc decl) = case decl of briDoc <- briDocMToPPM $ do eitherNode <- layoutBind (L loc bind) case eitherNode of - Left ns -> docLines $ return <$> ns + Left ns -> docLines $ return <$> ns Right n -> return n layoutBriDoc d briDoc - _ -> - briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d + _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d _sigHead :: Sig RdrName -> String _sigHead = \case - TypeSig names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) + TypeSig names _ -> + "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) _ -> "unknown sig" _bindHead :: HsBind RdrName -> String diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index 4f1ea65..a2d8f6b 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -66,65 +66,79 @@ import qualified Control.Monad.Trans.Writer.Strict as WriterS -layoutBriDoc :: Data.Data.Data ast - => ast - -> BriDocNumbered - -> PPM () +layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () layoutBriDoc ast briDoc = do -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw $ briDocToDoc $ unwrapBriDocNumbered $ briDoc -- bridoc transformation: remove alts transformAlts briDoc >>= mSet - mGet >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt . briDocToDoc + mGet + >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + . briDocToDoc -- bridoc transformation: float stuff in mGet <&> transformSimplifyFloating >>= mSet - mGet >>= traceIfDumpConf "bridoc post-floating" _dconf_dump_bridoc_simpl_floating . briDocToDoc + mGet + >>= traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating + . briDocToDoc -- bridoc transformation: par removal mGet <&> transformSimplifyPar >>= mSet - mGet >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par . briDocToDoc + mGet + >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + . briDocToDoc -- bridoc transformation: float stuff in mGet <&> transformSimplifyColumns >>= mSet - mGet >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns . briDocToDoc + mGet + >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + . briDocToDoc -- -- bridoc transformation: indent mGet <&> transformSimplifyIndent >>= mSet - mGet >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent . briDocToDoc - mGet >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final . briDocToDoc + mGet + >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + . briDocToDoc + mGet + >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + . briDocToDoc -- -- convert to Simple type -- simpl <- mGet <&> transformToSimple -- return simpl - + anns :: ExactPrint.Types.Anns <- mAsk let filteredAnns = filterAnns ast anns - traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations $ annsDoc filteredAnns - + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns + let state = LayoutState - { _lstate_baseYs = [0] + { _lstate_baseYs = [0] , _lstate_curYOrAddNewline = Right 0 -- important that we use left here -- because moveToAnn stuff of the -- first node needs to do its -- thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = filteredAnns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = filteredAnns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_inhibitMTEL = False } - state' <- MultiRWSS.withMultiStateS state - $ layoutBriDocM briDoc' - - let remainingComments = - extractAllComments =<< Map.elems (_lstate_comments state') - remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst) - + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + + let + remainingComments = + extractAllComments =<< Map.elems (_lstate_comments state') + remainingComments + `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst) + return $ () + data AltCurPos = AltCurPos { _acp_line :: Int -- chars in the current line , _acp_indent :: Int -- current indentation level @@ -142,16 +156,16 @@ data AltLineModeState deriving (Show) 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 altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos @@ -159,7 +173,8 @@ mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of (AltLineModeStateContradiction, _) -> acp (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp - (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> acp { _acp_forceMLFlag = s } + (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> + acp { _acp_forceMLFlag = s } _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } -- removes any BDAlt's from the BriDoc @@ -170,10 +185,12 @@ transformAlts ) => BriDocNumbered -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts briDoc - = MultiRWSS.withMultiStateA - (AltCurPos 0 0 0 AltLineModeStateNone) - $ Memo.startEvalMemoT $ fmap unwrapBriDocNumbered $ rec $ briDoc +transformAlts briDoc = + MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) + $ Memo.startEvalMemoT + $ fmap unwrapBriDocNumbered + $ rec + $ briDoc where -- this funtion is exponential by nature and cannot be improved in any -- way i can think of, and if tried. (stupid StableNames.) @@ -459,7 +476,11 @@ transformAlts briDoc hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) = line + sameLine <= confUnpack (_lconfig_cols lconf) -getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m (LineModeValidity VerticalSpacing) +getSpacing + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => BriDocNumbered + -> m (LineModeValidity VerticalSpacing) getSpacing !bridoc = rec bridoc where rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) @@ -637,8 +658,12 @@ getSpacing !bridoc = rec bridoc VerticalSpacingParNone -> 0 VerticalSpacingParAlways i -> i -getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => Int -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] +getSpacings + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => Int + -> BriDocNumbered + -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] getSpacings limit bridoc = preFilterLimit <$> rec bridoc where preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] @@ -883,21 +908,21 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc -- 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 BrIndentNone x = x +mergeIndents x BrIndentNone = x mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" +mergeIndents _ _ = error "mergeIndents" -- TODO: move to uniplate upstream? -- aka `transform` -transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) transformUp f = g where g = f . Uniplate.descend g _transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) _transformDown f = g where g = Uniplate.descend g . f -transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x -_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) _transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x @@ -1078,29 +1103,31 @@ transformSimplifyPar = transformUp $ \case -- Just $ BDPar ind1 line (BDLines [p1, p2]) x@(BDPar _ (BDPar _ BDPar{} _) _) -> x BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> - BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1: indenteds)) + BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines | any (\case BDLines{} -> True - BDEmpty{} -> True - _ -> False) lines -> - case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs - where - go = (=<<) $ \case - BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs + where + go = (=<<) $ \case + BDLines l -> go l + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x -- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- BDPar BrIndentNone line indented -> -- Just $ BDLines [line, indented] BDEnsureIndent BrIndentNone x -> x - x -> x + x -> x isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False @@ -1243,28 +1270,29 @@ transformSimplifyIndent = Uniplate.rewrite $ \case -- [ BDAddBaseY ind x -- , BDEnsureIndent ind indented -- ] - BDLines lines | any (\case BDLines{} -> True - BDEmpty{} -> True - _ -> False) lines -> + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l - x -> [x] - BDLines [l] -> - Just l + x -> [x] + BDLines [l] -> Just l BDAddBaseY i (BDAnnotationPrior k x) -> Just $ BDAnnotationPrior k (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationKW k kw x) -> + BDAddBaseY i (BDAnnotationKW k kw x) -> Just $ BDAnnotationKW k kw (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationRest k x) -> + BDAddBaseY i (BDAnnotationRest k x) -> Just $ BDAnnotationRest k (BDAddBaseY i x) BDAddBaseY i (BDSeq l) -> Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY i (BDCols sig l) -> Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] - BDAddBaseY _ lit@BDLit{} -> - Just lit + BDAddBaseY _ lit@BDLit{} -> Just lit - _ -> Nothing + _ -> Nothing briDocLineLength :: BriDoc -> Int @@ -1273,35 +1301,35 @@ 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 - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ 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 + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ 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 - BDProhibitMTEL bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd - BDDebug _ bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDProhibitMTEL bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing bd -> rec bd + BDDebug _ bd -> rec bd layoutBriDocM :: forall w m diff --git a/src/Language/Haskell/Brittany/Config.hs b/src/Language/Haskell/Brittany/Config.hs index 9f3002b..e42eadd 100644 --- a/src/Language/Haskell/Brittany/Config.hs +++ b/src/Language/Haskell/Brittany/Config.hs @@ -73,36 +73,42 @@ import Data.Coerce ( Coercible, coerce ) configParser :: CmdParser Identity out (ConfigF Option) configParser = do -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParam "" ["indent"] "AMOUNT" - (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParam "" ["columns"] "AMOUNT" - (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParam "" ["import-col"] "N" - (flagHelpStr "column to align import lists at") + ind <- addFlagReadParam "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParam "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParam "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (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") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpBriDocFloating <- addSimpleBoolFlag "" + ["dump-bridoc-floating"] + (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + + optionsGhc <- addFlagStringParam + "" + ["ghc-options"] + "STRING" + ( flagHelp + $ parDoc + "allows to define default language extensions. The parameter is forwarded to ghc. Note that currently these options are applied _after_ the pragmas read in from the input." + ) - optionsGhc <- addFlagStringParam "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc. Note that currently these options are applied _after_ the pragmas read in from the input.") - return $ Config - { _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 + { _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 @@ -111,7 +117,7 @@ configParser = do , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal } - , _conf_layout = LayoutConfig + , _conf_layout = LayoutConfig { _lconfig_cols = optionConcat cols , _lconfig_indentPolicy = mempty , _lconfig_indentAmount = optionConcat ind @@ -126,18 +132,16 @@ configParser = do , _econf_Werror = wrapLast $ falseToNothing wError , _econf_CPPMode = mempty } - , _conf_forward = ForwardOptions - { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs - | not $ null optionsGhc - ] + , _conf_forward = ForwardOptions + { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } } - where falseToNothing = Option . Bool.bool Nothing (Just True) - wrapLast :: Option a -> Option (Semigroup.Last a) - wrapLast = fmap Semigroup.Last - optionConcat - :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a) - optionConcat = mconcat . fmap (pure . pure) + where + falseToNothing = Option . Bool.bool Nothing (Just True) + wrapLast :: Option a -> Option (Semigroup.Last a) + wrapLast = fmap Semigroup.Last + optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a) + optionConcat = mconcat . fmap (pure . pure) -- configParser :: Parser Config -- configParser = Config diff --git a/src/Language/Haskell/Brittany/Config/Types.hs b/src/Language/Haskell/Brittany/Config/Types.hs index a655a74..d64575d 100644 --- a/src/Language/Haskell/Brittany/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Config/Types.hs @@ -227,38 +227,38 @@ data CPPMode = CPPModeAbort -- abort program on seeing -XCPP staticDefaultConfig :: Config staticDefaultConfig = Config - { _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 - } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) - , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_CPPMode = coerce CPPModeAbort - } - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } + { _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 } + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_CPPMode = coerce CPPModeAbort + } + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] + } + } -- TODO: automate writing instances for this to get -- the above Monoid instance for free. diff --git a/src/Language/Haskell/Brittany/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/ExactPrintUtils.hs index 99b7922..1067b1b 100644 --- a/src/Language/Haskell/Brittany/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/ExactPrintUtils.hs @@ -149,31 +149,34 @@ commentAnnFixTransformGlob ast = do let priors = ExactPrint.annPriorComments ann1 follows = ExactPrint.annFollowingComments ann1 assocs = ExactPrint.annsDP ann1 - let processCom - :: (ExactPrint.Comment, ExactPrint.DeltaPos) - -> ExactPrint.TransformT Identity Bool - processCom comPair@(com, _) = - case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of - GHC.UnhelpfulLoc{} -> return True -- retain comment at current node. - GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of - Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of - (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> - move $> False - (x,y) | x==y -> move $> False - _ -> return True - where - ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 - ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.srcSpanStart annKeyLoc1 - loc2 = GHC.srcSpanStart annKeyLoc2 - move = ExactPrint.modifyAnnsT $ \anns -> - let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns - ann2' = ann2 - { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] - } - in Map.insert annKey2 ann2' anns - _ -> return True -- retain comment at current node. + let + processCom + :: (ExactPrint.Comment, ExactPrint.DeltaPos) + -> ExactPrint.TransformT Identity Bool + processCom comPair@(com, _) = + case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of + GHC.UnhelpfulLoc{} -> return True -- retain comment at current node. + GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of + Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of + (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> + move $> False + (x, y) | x == y -> move $> False + _ -> return True + where + ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 + ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 + loc1 = GHC.srcSpanStart annKeyLoc1 + loc2 = GHC.srcSpanStart annKeyLoc2 + move = ExactPrint.modifyAnnsT $ \anns -> + let + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2' = ann2 + { ExactPrint.annFollowingComments = + ExactPrint.annFollowingComments ann2 ++ [comPair] + } + in + Map.insert annKey2 ann2' anns + _ -> return True -- retain comment at current node. priors' <- flip filterM priors processCom follows' <- flip filterM follows $ processCom assocs' <- flip filterM assocs $ \case diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index 76fc7f1..dfd5509 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -135,11 +135,13 @@ traceLocal x = do traceLocal _ = return () #endif -processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter - Text.Builder.Builder m, - MonadMultiReader ExactPrint.Types.Anns m) - => GenLocated SrcSpan ast - -> m () +processDefault + :: ( ExactPrint.Annotate.Annotate ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiReader ExactPrint.Types.Anns m + ) + => GenLocated SrcSpan ast + -> m () processDefault x = do anns <- mAsk let str = ExactPrint.exactPrint x anns @@ -152,55 +154,66 @@ processDefault x = do "\n" -> return () _ -> mTell $ Text.Builder.fromString $ str -briDocByExact :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered +-- | Use ExactPrint's output for this node; add a newly generated inline comment +-- at insertion position (meant to point out to the user that this node is +-- not handled by brittany yet). Useful when starting implementing new +-- syntactic constructs when children are not handled yet. +briDocByExact + :: (ExactPrint.Annotate.Annotate ast) + => GenLocated SrcSpan ast + -> 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 -briDocByExactNoComment :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered +-- | Use ExactPrint's output for this node. +briDocByExactNoComment + :: (ExactPrint.Annotate.Annotate ast) + => GenLocated SrcSpan ast + -> 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 rdrNameToText :: RdrName -> Text -- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr -rdrNameToText ( Unqual occname ) = Text.pack $ occNameString occname -rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname - ++ "." - ++ occNameString occname -rdrNameToText ( Orig modul occname ) = Text.pack $ moduleNameString (moduleName modul) - ++ occNameString occname -rdrNameToText ( Exact name ) = Text.pack $ getOccString name +rdrNameToText (Unqual occname) = Text.pack $ occNameString occname +rdrNameToText (Qual mname occname) = + Text.pack $ moduleNameString mname ++ "." ++ occNameString occname +rdrNameToText (Orig modul occname) = + Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname +rdrNameToText (Exact name) = Text.pack $ getOccString name lrdrNameToText :: GenLocated l RdrName -> Text lrdrNameToText (L _ n) = rdrNameToText n -lrdrNameToTextAnn :: ( MonadMultiReader Config m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => GenLocated SrcSpan RdrName - -> m Text +lrdrNameToTextAnn + :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + => GenLocated SrcSpan RdrName + -> m Text lrdrNameToTextAnn ast@(L _ n) = do anns <- mAsk let t = rdrNameToText n - let hasUni x (ExactPrint.Types.G y, _) = x==y - hasUni _ _ = False + 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 lrdrNameToTextAnnTypeEqualityIsSpecial :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) @@ -209,18 +222,19 @@ lrdrNameToTextAnnTypeEqualityIsSpecial lrdrNameToTextAnnTypeEqualityIsSpecial ast = do x <- lrdrNameToTextAnn ast return $ if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x askIndent :: (MonadMultiReader Config m) => m Int askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk -layoutWriteAppend :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => Text - -> m () +layoutWriteAppend + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Text + -> m () layoutWriteAppend t = do traceLocal ("layoutWriteAppend", t) state <- mGet @@ -250,32 +264,32 @@ layoutWriteAppend t = do , _lstate_addSepSpace = Nothing } -layoutWriteAppendSpaces :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => Int - -> m () +layoutWriteAppendSpaces + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () layoutWriteAppendSpaces i = do traceLocal ("layoutWriteAppendSpaces", i) - unless (i==0) $ do + unless (i == 0) $ do state <- mGet - mSet $ state { _lstate_addSepSpace = Just - $ maybe i (+i) - $ _lstate_addSepSpace state - } + mSet $ state + { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state + } -layoutWriteAppendMultiline :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => Text - -> m () +layoutWriteAppendMultiline + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Text + -> m () layoutWriteAppendMultiline t = do traceLocal ("layoutWriteAppendMultiline", t) case Text.lines t of - [] -> - layoutWriteAppend t -- need to write empty, too. + [] -> layoutWriteAppend t -- need to write empty, too. (l:lr) -> do layoutWriteAppend l lr `forM_` \x -> do @@ -283,17 +297,18 @@ layoutWriteAppendMultiline t = do layoutWriteAppend x -- adds a newline and adds spaces to reach the base column. -layoutWriteNewlineBlock :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => m () +layoutWriteNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () layoutWriteNewlineBlock = do traceLocal ("layoutWriteNewlineBlock") state <- mGet mSet $ state { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_inhibitMTEL = False + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_inhibitMTEL = False } -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m @@ -310,13 +325,12 @@ layoutWriteNewlineBlock = do -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } -layoutSetCommentCol :: ( MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m ) - => m () +layoutSetCommentCol + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () layoutSetCommentCol = do state <- mGet let col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Right{} -> lstate_baseY state traceLocal ("layoutSetCommentCol", col) unless (Data.Maybe.isJust $ _lstate_commentCol state) @@ -337,90 +351,93 @@ layoutMoveToCommentPos y x = do then do 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 = Just $ case _lstate_curYOrAddNewline state of - Left{} -> if y==0 - then x - else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x } else do mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y==0 then Left i else Right y + Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = Just $ if y==0 - then x - else _lstate_indLevelLinger state + x + , _lstate_addSepSpace = Just + $ if y == 0 then x else _lstate_indLevelLinger state + x , _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state } -- | does _not_ add spaces to again reach the current base column. -layoutWriteNewline :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => m () +layoutWriteNewline + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () layoutWriteNewline = do traceLocal ("layoutWriteNewline") state <- mGet - mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right (i+1) - , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False - } + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right (i + 1) + , _lstate_addSepSpace = Nothing + , _lstate_inhibitMTEL = False + } -layoutWriteEnsureNewlineBlock :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => m () +layoutWriteEnsureNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () layoutWriteEnsureNewlineBlock = do traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_inhibitMTEL = False - , _lstate_commentCol = Nothing + Left{} -> Right 1 + Right i -> Right $ max 1 i + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_inhibitMTEL = False + , _lstate_commentCol = Nothing } -layoutWriteEnsureBlock :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => m () +layoutWriteEnsureBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) 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 } -layoutWriteEnsureAbsoluteN :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => Int -> m () +layoutWriteEnsureAbsoluteN + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet let diff = case _lstate_curYOrAddNewline state of - Left i -> n-i + Left i -> n - i Right{} -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) - when (diff>0) $ do + when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to -- at least (Just 1), so we won't -- overwrite any old value in any @@ -448,7 +465,7 @@ layoutIndentLevelPushInternal layoutIndentLevelPushInternal i = do traceLocal ("layoutIndentLevelPushInternal", i) mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s + , _lstate_indLevels = i : _lstate_indLevels s } layoutIndentLevelPopInternal @@ -456,7 +473,7 @@ layoutIndentLevelPopInternal layoutIndentLevelPopInternal = do traceLocal ("layoutIndentLevelPopInternal") mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s + , _lstate_indLevels = List.tail $ _lstate_indLevels s } layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m @@ -469,13 +486,14 @@ layoutRemoveIndentLevelLinger = do mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } -layoutWithAddBaseCol :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - ,MonadMultiReader Config m - , MonadMultiWriter (Seq String) m) - => m () - -> m () +layoutWithAddBaseCol + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + , MonadMultiWriter (Seq String) m + ) + => m () + -> m () layoutWithAddBaseCol m = do #if INSERTTRACES tellDebugMessShow ("layoutWithAddBaseCol") @@ -521,13 +539,14 @@ layoutWithAddBaseColNBlock amount m = do m layoutBaseYPopInternal -layoutWithAddBaseColN :: (MonadMultiWriter - Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => Int - -> m () - -> m () +layoutWithAddBaseColN + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () + -> m () layoutWithAddBaseColN amount m = do #if INSERTTRACES tellDebugMessShow ("layoutWithAddBaseColN", amount) @@ -543,10 +562,11 @@ 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 + Nothing -> + case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i , Just j ) -> layoutBaseYPushInternal (i + j) + (Left i , Nothing) -> layoutBaseYPushInternal i + (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state Just cCol -> layoutBaseYPushInternal cCol layoutBaseYPop @@ -561,9 +581,9 @@ 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 + (Left i , Just j ) -> i + j + (Left i , Nothing) -> i + (Right{}, Just j ) -> j (Right{}, Nothing) -> 0 layoutIndentLevelPushInternal y layoutBaseYPushInternal y @@ -588,7 +608,8 @@ layoutAddSepSpace = do tellDebugMessShow ("layoutAddSepSpace") #endif state <- mGet - mSet $ state { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } + mSet $ state + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. @@ -604,22 +625,25 @@ 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.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann -- mModify $ \state -> state { _lstate_addNewline = Just x } mModify $ \state -> let upd = case _lstate_curYOrAddNewline state of - Left i -> if y==0 then Left i else Right y + 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 - } + 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 @@ -628,18 +652,22 @@ moveToExactAnn annKey = do -- then x-1 -- else x -ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m - => ExactPrint.Types.DeltaPos - -> m () -ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do +ppmMoveToExactLoc + :: MonadMultiWriter Text.Builder.Builder m + => ExactPrint.Types.DeltaPos + -> m () +ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ y $ mTell $ Text.Builder.fromString " " -layoutWritePriorComments :: (Data.Data.Data ast, - MonadMultiWriter Text.Builder.Builder m, - MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m) - => GenLocated SrcSpan ast -> m () +layoutWritePriorComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => GenLocated SrcSpan ast + -> m () layoutWritePriorComments ast = do mAnn <- do state <- mGet @@ -743,49 +771,43 @@ extractAllComments extractAllComments ann = ExactPrint.annPriorComments ann ++ ExactPrint.annFollowingComments ann - ++ (ExactPrint.annsDP ann >>= \case + ++ ( ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] + _ -> [] ) -foldedAnnKeys :: Data.Data.Data ast - => ast - -> Set ExactPrint.AnnKey +foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys ast = everything Set.union - (\x -> maybe - Set.empty - Set.singleton - [ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x - | locTyCon == typeRepTyCon (typeOf x) - , l <- gmapQi 0 cast x - ] + ( \x -> maybe Set.empty + Set.singleton + [ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x + | locTyCon == typeRepTyCon (typeOf x) + , l <- gmapQi 0 cast x + ] ) ast where locTyCon = typeRepTyCon (typeOf (L () ())) -filterAnns :: Data.Data.Data ast - => ast - -> ExactPrint.Anns - -> ExactPrint.Anns +filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns ast anns = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow ast@(L l _) = do anns <- filterAnns ast <$> mAsk - return $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) - $ (=<<) extractAllComments - $ Map.elems - $ anns + return + $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) + $ (=<<) extractAllComments + $ Map.elems + $ anns -- new BriDoc stuff -allocateNode :: MonadMultiState NodeAllocIndex m - => BriDocFInt - -> m BriDocNumbered +allocateNode + :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered allocateNode bd = do i <- allocNodeIndex return (i, bd) @@ -793,7 +815,7 @@ allocateNode bd = do allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int allocNodeIndex = do NodeAllocIndex i <- mGet - mSet $ NodeAllocIndex (i+1) + mSet $ NodeAllocIndex (i + 1) return i -- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered @@ -901,13 +923,17 @@ docEmpty = allocateNode BDFEmpty docLit :: Text -> ToBriDocM BriDocNumbered docLit t = allocateNode $ BDFLit t -docExt :: (ExactPrint.Annotate.Annotate ast) - => GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> Bool -> ToBriDocM BriDocNumbered +docExt + :: (ExactPrint.Annotate.Annotate ast) + => GenLocated SrcSpan ast + -> ExactPrint.Types.Anns + -> Bool + -> ToBriDocM BriDocNumbered docExt x anns shouldAddComment = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey x) - (foldedAnnKeys x) - shouldAddComment - (Text.pack $ ExactPrint.exactPrint x anns) + (ExactPrint.Types.mkAnnKey x) + (foldedAnnKeys x) + shouldAddComment + (Text.pack $ ExactPrint.exactPrint x anns) docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt l = allocateNode . BDFAlt =<< sequence l @@ -955,7 +981,10 @@ docAnnotationPrior docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm docAnnotationKW - :: AnnKey -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + :: AnnKey + -> Maybe AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docAnnotationRest @@ -1110,11 +1139,12 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where -docPar :: ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered +docPar + :: ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered docPar lineM indentedM = do - line <- lineM + line <- lineM indented <- indentedM allocateNode $ BDFPar BrIndentNone line indented @@ -1124,7 +1154,8 @@ docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm -docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docEnsureIndent + :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError @@ -1140,13 +1171,14 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] briDocMToPPM :: ToBriDocM a -> PPM a briDocMToPPM 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 mTell debugs mTell errs return x diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index 55ef0eb..dde640f 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -41,52 +41,63 @@ layoutSig lsig@(L _loc sig) = case sig of TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ + typeDoc <- docSharedWrapper layoutType typ hasComments <- hasAnyCommentsBelow lsig - docAlt $ - [ docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr - , appSep $ docLit $ Text.pack "::" - , docForceSingleline typeDoc - ] - | not hasComments - ] ++ - [ docAddBaseY BrIndentRegular - $ docPar - (docWrapNodeRest lsig $ docLit nameStr) - ( docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ) - ] - _ -> briDocByExactNoComment lsig -- TODO + docAlt + $ [ docSeq + [ appSep $ docWrapNodeRest lsig $ docLit nameStr + , appSep $ docLit $ Text.pack "::" + , docForceSingleline typeDoc + ] + | not hasComments + ] + ++ [ docAddBaseY BrIndentRegular $ docPar + (docWrapNodeRest lsig $ docLit nameStr) + ( docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ) + ] + _ -> briDocByExactNoComment lsig -- TODO layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName)) 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 + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO -layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered) +layoutBind + :: ToBriDocC + (HsBindLR RdrName RdrName) + (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" - funcPatDocs <- docWrapNode lbind $ docWrapNode lmatches $ layoutPatternBind (Just idStr) binderDoc `mapM` matches + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" + funcPatDocs <- + docWrapNode lbind + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches return $ Left $ funcPatDocs PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat + patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds - binderDoc <- docLit $ Text.pack "=" - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs mWhereDocs + binderDoc <- docLit $ Text.pack "=" + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereDocs _ -> Right <$> unknownNodeError "" lbind data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName) @@ -96,210 +107,250 @@ bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l -layoutLocalBinds :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered]) +layoutLocalBinds + :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered]) layoutLocalBinds lbinds@(L _ binds) = case binds of -- HsValBinds (ValBindsIn lhsBindsLR []) -> -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds (ValBindsIn bindlrs sigs) -> do - let unordered = [BagBind b | b <- Data.Foldable.toList bindlrs] ++ [BagSig s | s <- sigs] - ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered + let + unordered + = [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered docs <- docWrapNode lbinds $ join <$> ordered `forM` \case - BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s + BagBind b -> either id return <$> layoutBind b + BagSig s -> return <$> layoutSig s return $ Just $ docs x@(HsValBinds (ValBindsOut _binds _lsigs)) -> -- i _think_ this case never occurs in non-processed ast Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x - x@(HsIPBinds _ipBinds) -> - Just . (:[]) <$> unknownNodeError "HsIPBinds" x - EmptyLocalBinds -> - return $ Nothing + x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x + EmptyLocalBinds -> return $ Nothing -- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is -- parSpacing stuff.B -layoutGrhs :: LGRHS RdrName (LHsExpr RdrName) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName) -layoutGrhs lgrhs@(L _ (GRHS guards body)) - = do - guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body - return (guardDocs, bodyDoc, body) +layoutGrhs + :: LGRHS RdrName (LHsExpr RdrName) + -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName) +layoutGrhs lgrhs@(L _ (GRHS guards body)) = do + guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards + bodyDoc <- layoutExpr body + return (guardDocs, bodyDoc, body) -layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered -layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) - = do - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p - let isInfix = isInfixMatch match - patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of - (Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix - ( [ appSep $ docForceSingleline p1 - , appSep $ docLit idStr - ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) - (Just idStr, []) -> docLit idStr - (Just idStr, ps) -> docCols ColPatternsFuncPrefix +layoutPatternBind + :: Maybe Text + -> BriDocNumbered + -> LMatch RdrName (LHsExpr RdrName) + -> ToBriDocM BriDocNumbered +layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do + patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + let isInfix = isInfixMatch match + patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of + (Just idStr, p1:pr) | isInfix -> docCols + ColPatternsFuncInfix + ( [appSep $ docForceSingleline p1, appSep $ docLit idStr] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) + (Just idStr, [] ) -> docLit idStr + (Just idStr, ps) -> + docCols ColPatternsFuncPrefix $ appSep (docLit $ idStr) : (spacifyDocs $ docForceSingleline <$> ps) - (Nothing, ps) -> docCols ColPatterns + (Nothing, ps) -> + docCols ColPatterns $ (List.intersperse docSeparator $ docForceSingleline <$> ps) - clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let alignmentToken = if null pats then Nothing else mIdStr - layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs mWhereDocs + clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss + mWhereDocs <- layoutLocalBinds whereBinds + let alignmentToken = if null pats then Nothing else mIdStr + layoutPatternBindFinal alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereDocs -layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] -> Maybe [BriDocNumbered] -> ToBriDocM BriDocNumbered +layoutPatternBindFinal + :: Maybe Text + -> BriDocNumbered + -> Maybe BriDocNumbered + -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] + -> Maybe [BriDocNumbered] + -> ToBriDocM BriDocNumbered layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs = do - let patPartInline = case mPatDoc of - Nothing -> [] + 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 <- mAsk - <&> _conf_layout - .> _lconfig_indentWhereSpecial - .> confUnpack - .> Bool.bool BrIndentRegular (BrIndentSpecial 1) + whereIndent <- + mAsk + <&> _conf_layout + .> _lconfig_indentWhereSpecial + .> confUnpack + .> Bool.bool BrIndentRegular (BrIndentSpecial 1) -- 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 ws -> fmap (fmap return) $ sequence $ return @[] - $ docEnsureIndent whereIndent - $ docLines + Nothing -> return $ [] + Just ws -> + fmap (fmap return) + $ sequence + $ return @[] + $ docEnsureIndent whereIndent + $ docLines [ docLit $ Text.pack "where" , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return <$> ws + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws ] - docAlt $ - -- one-line solution - [ docCols (ColBindingLine alignmentToken) - [ docSeq - (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = case guards of - [] -> docEmpty - [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ++ [docSeparator] - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w + docAlt + $ -- one-line solution + [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart + ] + ] + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let + guardPart = case guards of + [] -> docEmpty + [g] -> + docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] + gs -> + docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ++ [docSeparator] + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> [] + ] + ++ -- one-line solution + where in next line(s) + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let + guardPart = case guards of + [] -> docEmpty + [g] -> + docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] + gs -> + docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ++ [docSeparator] + , Data.Maybe.isJust mWhereDocs + ] + ++ -- two-line solution + where in next line(s) + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let + guardPart = case guards of + [] -> docEmpty + [g] -> + docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] + gs -> + docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ++ [docSeparator] + ] + ++ -- pattern and exactly one clause in single line, body as par; + -- where in following lines + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [appSep guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] ] - _ -> [] - ] ++ - -- one-line solution + where in next line(s) - [ docLines - $ [ docCols (ColBindingLine alignmentToken) - [ docSeq - (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ return body - ] - ] - ] ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = case guards of - [] -> docEmpty - [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ++ [docSeparator] - , Data.Maybe.isJust mWhereDocs - ] ++ - -- two-line solution + where in next line(s) - [ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular - $ docForceSingleline - $ return body - ] ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = case guards of - [] -> docEmpty - [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ++ [docSeparator] - ] ++ - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - [ docLines - $ [ docCols (ColBindingLine alignmentToken) - [ docSeq - (patPartInline ++ [appSep guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body -- , lineMod $ docAlt -- [ docSetBaseY $ return body -- , docAddBaseY BrIndentRegular $ return body -- ] - ] - ] - ] ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = case guards of - [] -> docEmpty - [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] ++ - -- pattern and exactly one clause in single line, body in new line. - [ docLines - $ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular - $ docNonBottomSpacing - $ (docAddBaseY BrIndentRegular $ return body) - ] ++ wherePartMultiLine - | [(guards, body, _)] <- [clauseDocs] - , let guardPart = case guards of - [] -> docEmpty - [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] - gs -> docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] ++ - -- conservative approach: everything starts on the left. - [ docLines $ - [ patPartParWrap - $ docLines - $ fmap (docEnsureIndent BrIndentRegular) - $ 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 + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let + guardPart = case guards of + [] -> docEmpty + [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] + gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse + docCommaSep + (return <$> gs) + ] + ++ -- pattern and exactly one clause in single line, body in new line. + [ docLines + $ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular + $ docNonBottomSpacing + $ (docAddBaseY BrIndentRegular $ return body) ] - ] ++ wherePartMultiLine - ] + ++ wherePartMultiLine + | [(guards, body, _)] <- [clauseDocs] + , let + guardPart = case guards of + [] -> docEmpty + [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] + gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse + docCommaSep + (return <$> gs) + ] + ++ -- conservative approach: everything starts on the left. + [ docLines + $ [ patPartParWrap + $ docLines + $ fmap (docEnsureIndent BrIndentRegular) + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1:gr) -> + ( docSeq [appSep $ docLit $ Text.pack "|", return g1] + : ( gr + <&> \g -> + docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + ] diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index 38bdeee..66ffeb8 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs @@ -777,19 +777,19 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of litBriDoc :: HsLit -> BriDocFInt litBriDoc = \case - HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger t _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat (FL t _) _type -> BDFLit $ Text.pack t - HsFloatPrim (FL t _) -> BDFLit $ Text.pack t - HsDoublePrim (FL t _) -> BDFLit $ Text.pack t + HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger t _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat (FL t _) _type -> BDFLit $ Text.pack t + HsFloatPrim (FL t _) -> BDFLit $ Text.pack t + HsDoublePrim (FL t _) -> BDFLit $ Text.pack t overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc = \case diff --git a/src/Language/Haskell/Brittany/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Layouters/Stmt.hs index 51446ed..d445a75 100644 --- a/src/Language/Haskell/Brittany/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Layouters/Stmt.hs @@ -28,51 +28,50 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of - LastStmt body False _ -> do + LastStmt body False _ -> do layoutExpr body BindStmt lPat expr _ _ _ -> do patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat expDoc <- docSharedWrapper layoutExpr expr docAlt - [ docCols ColBindStmt + [ docCols + ColBindStmt [ appSep patDoc , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] ] - , docCols ColBindStmt + , docCols + ColBindStmt [ appSep patDoc , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "<-") - (expDoc) + $ docPar (docLit $ Text.pack "<-") (expDoc) ] ] - LetStmt binds -> layoutLocalBinds binds >>= \case - Nothing -> - docLit $ Text.pack "let" -- i just tested + LetStmt binds -> layoutLocalBinds binds >>= \case + Nothing -> docLit $ Text.pack "let" -- i just tested -- it, and it is -- indeed allowed. -- heh. - Just [] -> - docLit $ Text.pack "let" -- this probably never happens + Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [bindDoc] -> docAlt - [ docCols ColDoLet + [ docCols + ColDoLet [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ return bindDoc ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) ] - Just bindDocs -> docAlt + Just bindDocs -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" , docSetBaseAndIndent $ docLines $ return <$> bindDocs ] - , docAddBaseY BrIndentRegular - $ docPar + , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) ] - BodyStmt expr _ _ _ -> do + BodyStmt expr _ _ _ -> do expDoc <- docSharedWrapper layoutExpr expr docAddBaseY BrIndentRegular $ expDoc - _ -> unknownNodeError "" lstmt + _ -> unknownNodeError "" lstmt diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index 8d6049e..4a7bf64 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -296,88 +296,89 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDCols sig list) = plate BDCols |- sig ||* list uniplate x@BDSeparator = plate x uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd + uniplate (BDAlt alts) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd uniplate x@BDExternal{} = plate x uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd + uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd + uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd - uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd + uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd + uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd uniplate (BDDebug s bd) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int unwrapBriDocNumbered :: BriDocNumbered -> BriDoc unwrapBriDocNumbered tpl = case snd tpl of - BDFEmpty -> BDEmpty - BDFLit t -> BDLit t - BDFSeq list -> BDSeq $ rec <$> list - BDFCols sig list -> BDCols sig $ rec <$> list - BDFSeparator -> BDSeparator - BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDFBaseYPop bd -> BDBaseYPop $ rec bd - BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDFPar ind line indented -> BDPar ind (rec line) (rec indented) - BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDFForwardLineMode bd -> BDForwardLineMode $ rec bd - BDFExternal k ks c t -> BDExternal k ks c t + BDFEmpty -> BDEmpty + BDFLit t -> BDLit t + BDFSeq list -> BDSeq $ rec <$> list + BDFCols sig list -> BDCols sig $ rec <$> list + BDFSeparator -> BDSeparator + BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDFBaseYPop bd -> BDBaseYPop $ rec bd + BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDFPar ind line indented -> BDPar ind (rec line) (rec indented) + BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDFForwardLineMode bd -> BDForwardLineMode $ rec bd + BDFExternal k ks c t -> BDExternal k ks c t BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd - BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFLines lines -> BDLines $ rec <$> lines - BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd - BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd + BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFLines lines -> BDLines $ rec <$> lines + BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered +-- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDProhibitMTEL bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDProhibitMTEL bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd diff --git a/src/Language/Haskell/Brittany/Utils.hs b/src/Language/Haskell/Brittany/Utils.hs index 8ff2e4e..090a620 100644 --- a/src/Language/Haskell/Brittany/Utils.hs +++ b/src/Language/Haskell/Brittany/Utils.hs @@ -76,13 +76,11 @@ showGhc :: (GHC.Outputable a) => a -> String showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = Data.Coerce.coerce - $ fromMaybe (Data.Coerce.coerce x) y +fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y fromOptionIdentity :: Identity a -> Option a -> Identity a -fromOptionIdentity x y = Data.Coerce.coerce - $ fromMaybe (Data.Coerce.coerce x) - $ getOption y +fromOptionIdentity x y = + Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y -- maximum monoid over N+0 -- or more than N, because Num is allowed. @@ -101,61 +99,68 @@ data A x = A ShowIsId x deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = - DataToLayouter $ f `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan - `ext2Q` located - where - DataToLayouter f = defaultLayouterF layoutF - simpleLayouter :: String -> NodeLayouter - simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) - showIsId :: ShowIsId -> NodeLayouter - showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s - fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter - bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString - srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter - -- $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" ++ showGhc ss ++ "}" - located :: (Data b,Data loc) => GHC.GenLocated loc b -> NodeLayouter - located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a - where - annStr = case cast ss of - Just (s :: GHC.SrcSpan) -> ShowIsId - $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) - Nothing -> ShowIsId "nnnnnnnn" + DataToLayouter + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan + `ext2Q` located + where + DataToLayouter f = defaultLayouterF layoutF + simpleLayouter :: String -> NodeLayouter + simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) + showIsId :: ShowIsId -> NodeLayouter + showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s + fastString = + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + -> NodeLayouter + bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + srcSpan :: GHC.SrcSpan -> NodeLayouter + srcSpan ss = simpleLayouter + -- $ "{"++ showSDoc_ (GHC.ppr ss)++"}" + $ "{" ++ showGhc ss ++ "}" + located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter + located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a + where + annStr = case cast ss of + Just (s :: GHC.SrcSpan) -> + ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) + Nothing -> ShowIsId "nnnnnnnn" customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = - DataToLayouter $ f `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan - `ext2Q` located - where - DataToLayouter f = defaultLayouterF layoutF - simpleLayouter :: String -> NodeLayouter - simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) - showIsId :: ShowIsId -> NodeLayouter - showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s - fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter - bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString - srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter - located (GHC.L _ss a) = runDataToLayouter layoutF a + DataToLayouter + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan + `ext2Q` located + where + DataToLayouter f = defaultLayouterF layoutF + simpleLayouter :: String -> NodeLayouter + simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) + showIsId :: ShowIsId -> NodeLayouter + showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s + fastString = + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString + -> NodeLayouter + bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString + srcSpan :: GHC.SrcSpan -> NodeLayouter + srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" + located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter + located (GHC.L _ss a) = runDataToLayouter layoutF a -- displayBriDocTree :: BriDoc -> PP.Doc -- displayBriDocTree = \case @@ -205,13 +210,12 @@ customLayouterNoAnnsF layoutF = -- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr] -- ++ [PP.text "]"] -traceIfDumpConf :: (MonadMultiReader - Config m, - Show a) - => String - -> (DebugConfig -> Identity (Semigroup.Last Bool)) - -> a - -> m () +traceIfDumpConf + :: (MonadMultiReader Config m, Show a) + => String + -> (DebugConfig -> Identity (Semigroup.Last Bool)) + -> a + -> m () traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () @@ -237,8 +241,8 @@ briDocToDoc = astToDoc . removeAnnotations removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x + BDAnnotationRest _ x -> x + x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc @@ -246,16 +250,16 @@ briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) -breakEither :: (a -> Either b c) -> [a] -> ([b],[c]) -breakEither _ [] = ([],[]) +breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) +breakEither _ [] = ([], []) breakEither fn (a1:aR) = case fn a1 of - Left b -> (b:bs,cs) - Right c -> (bs,c:cs) - where - (bs,cs) = breakEither fn aR + Left b -> (b : bs, cs) + Right c -> (bs, c : cs) + where + (bs, cs) = breakEither fn aR -spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1:xR) | Just y <- f x1 = (y:ys, xs) - where - (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) +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)