From da692a4341399390018fb03773e15865d967fb8c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 3 Aug 2017 14:23:41 +0200 Subject: [PATCH] Update showcases / Add more example layouts --- README.md | 3 +- Showcase.md | 288 --------------- doc/showcases/BrittanyComparison.md | 522 +++++++++++++++++++++++++++ doc/showcases/Layout_Alignment.md | 98 +++++ doc/showcases/Layout_Interactions.md | 63 ++++ doc/showcases/Layout_Types.md | 65 ++++ doc/showcases/Parser.md | 168 +++++++++ 7 files changed, 918 insertions(+), 289 deletions(-) delete mode 100644 Showcase.md create mode 100644 doc/showcases/BrittanyComparison.md create mode 100644 doc/showcases/Layout_Alignment.md create mode 100644 doc/showcases/Layout_Interactions.md create mode 100644 doc/showcases/Layout_Types.md create mode 100644 doc/showcases/Parser.md diff --git a/README.md b/README.md index 47606e9..360e3d2 100644 --- a/README.md +++ b/README.md @@ -3,10 +3,11 @@ haskell source code formatter ![Output sample](https://github.com/lspitzner/brittany/raw/master/brittany-sample.gif) -(see another demonstration in [Showcase.md](Showcase.md)) +(see [more examples and comparisons](/doc/showcases)) This project's goals roughly are to: +- Always retain the semantics of the source being transformed; - Be idempotent (this also directly ensures that only valid haskell is produced); - Support the full ghc-haskell syntax including syntactic extensions; diff --git a/Showcase.md b/Showcase.md deleted file mode 100644 index 05e3fd8..0000000 --- a/Showcase.md +++ /dev/null @@ -1,288 +0,0 @@ -# brittany showcase - -We will try to take the following module and try to fit it into 80 columns. - -## input - -~~~~ .hs --- 10 20 30 40 50 60 70 80 -module Language.Haskell.Brittany.BriLayouter - ( layoutBriDoc - ) -where - - - -layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () -layoutBriDoc ast briDoc = do - -- first step: transform the briDoc. - 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyFloating >>= mSet - 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyColumns >>= mSet - 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 - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - - anns :: ExactPrint.Types.Anns <- mAsk - let filteredAnns = filterAnns ast anns - - let state = LayoutState - { _lstate_baseY = 0 - , _lstate_curY = 0 - , _lstate_indLevel = 0 - , _lstate_indLevelLinger = 0 - , _lstate_commentsPrior = extractCommentsPrior filteredAnns - , _lstate_commentsPost = extractCommentsPost filteredAnns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False - , _lstate_isNewline = NewLineStateInit - } - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - - let remainingComments = Map.elems (_lstate_commentsPrior state') ++ Map.elems (_lstate_commentsPost state') - remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst) - - return $ () -~~~~ - -## `brittany` output - -~~~~ .hs --- 10 20 30 40 50 60 70 80 -module Language.Haskell.Brittany.BriLayouter - ( layoutBriDoc - ) -where - - - -layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () -layoutBriDoc ast briDoc = do - -- first step: transform the briDoc. - 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyFloating >>= mSet - 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyColumns >>= mSet - 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 - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - - anns :: ExactPrint.Types.Anns <- mAsk - let filteredAnns = filterAnns ast anns - - let state = LayoutState - { _lstate_baseY = 0 - , _lstate_curY = 0 - , _lstate_indLevel = 0 - , _lstate_indLevelLinger = 0 - , _lstate_commentsPrior = extractCommentsPrior filteredAnns - , _lstate_commentsPost = extractCommentsPost filteredAnns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False - , _lstate_isNewline = NewLineStateInit - } - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - - let remainingComments = Map.elems (_lstate_commentsPrior state') - ++ Map.elems (_lstate_commentsPost state') - remainingComments - `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst) - - return $ () -~~~~ - -In contrast, let us look at Chris Done's `hindent` (version `5.2.1`) re-formatting results for the same input: - -## `hindent` output - -~~~~ .hs --- 10 20 30 40 50 60 70 80 -module Language.Haskell.Brittany.BriLayouter - ( layoutBriDoc - ) where - -layoutBriDoc - :: Data.Data.Data ast - => ast -> BriDocNumbered -> PPM () -layoutBriDoc ast briDoc - -- first step: transform the briDoc. - = 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyFloating >>= mSet - 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyColumns >>= mSet - 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 - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - anns :: ExactPrint.Types.Anns <- mAsk - let filteredAnns = filterAnns ast anns - let state = - LayoutState - { _lstate_baseY = 0 - , _lstate_curY = 0 - , _lstate_indLevel = 0 - , _lstate_indLevelLinger = 0 - , _lstate_commentsPrior = extractCommentsPrior filteredAnns - , _lstate_commentsPost = extractCommentsPost filteredAnns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_inhibitMTEL = False - , _lstate_isNewline = NewLineStateInit - } - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - let remainingComments = - Map.elems (_lstate_commentsPrior state') ++ - Map.elems (_lstate_commentsPost state') - remainingComments `forM_` - (mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst) - return $ () -~~~~ - -and haskell-formatter (version 1.0.0) - -## `haskell-formatter` output - -~~~~ .hs --- 10 20 30 40 50 60 70 80 -module Language.Haskell.Brittany.BriLayouter (layoutBriDoc) where - -layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () -layoutBriDoc ast briDoc - -- first step: transform the briDoc. - = 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyFloating >>= mSet - 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 - -- bridoc transformation: float stuff in - mGet <&> transformSimplifyColumns >>= mSet - 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 - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - anns :: ExactPrint.Types.Anns <- mAsk - let filteredAnns = filterAnns ast anns - let state - = LayoutState{_lstate_baseY = 0, _lstate_curY = 0, - _lstate_indLevel = 0, _lstate_indLevelLinger = 0, - _lstate_commentsPrior = - extractCommentsPrior filteredAnns, - _lstate_commentsPost = - extractCommentsPost filteredAnns, - _lstate_commentCol = Nothing, - _lstate_addSepSpace = Nothing, - _lstate_inhibitMTEL = False, - _lstate_isNewline = NewLineStateInit} - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - let remainingComments - = Map.elems (_lstate_commentsPrior state') ++ - Map.elems (_lstate_commentsPost state') - remainingComments `forM_` - (mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst) - return $ () -~~~~ diff --git a/doc/showcases/BrittanyComparison.md b/doc/showcases/BrittanyComparison.md new file mode 100644 index 0000000..d2b0aa3 --- /dev/null +++ b/doc/showcases/BrittanyComparison.md @@ -0,0 +1,522 @@ + +versions used: + +- brittany-0.8.0.1 +- hindent-5.2.3 +- haskell-formatter-1.0.0 + +## simple nested ifs + +~~~~.hs +--------------------------------------------------------------- vvv brittany vvv +mybinding = if condition1 + then if condition2 + then if condition3 then 0 else 1 + else if condition3 then 2 else 3 + else 4 +---------------------------------------------------------------- vvv hindent vvv +mybinding = + if condition1 + then if condition2 + then if condition3 + then 0 + else 1 + else if condition3 + then 2 + else 3 + else 4 +------------------------------------------------------ vvv haskell-formatter vvv +mybinding + = if condition1 then + if condition2 then if condition3 then 0 else 1 else + if condition3 then 2 else 3 + else 4 +-------------------------------------------------------------------------------- +~~~~ + +## monad comprehension + alignment + +~~~~.hs +-- 10 20 30 40 50 60 70 80 +--------------------------------------------------------------- vvv brittany vvv +myBinding = + [ [ [ LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v + , LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v + , LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v + , LeguEosb i4 (v5 - i4) oieha ymuSreje v + , LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v + ] + | oyphEmedn <- sdliWmguje + , oieha <- ohzvIp + ] + | v5 < j6 + , sdliWmguje <- zedoaregeuKilb tua1 + , ohzvIp <- zedoaregeuKilb (0 - loy2) + ] +---------------------------------------------------------------- vvv hindent vvv +myBinding = + [ [ [ LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v + , LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v + , LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v + , LeguEosb i4 (v5 - i4) oieha ymuSreje v + , LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v + ] + | oyphEmedn <- sdliWmguje + , oieha <- ohzvIp + ] + | v5 < j6 + , sdliWmguje <- zedoaregeuKilb tua1 + , ohzvIp <- zedoaregeuKilb (0 - loy2) + ] +------------------------------------------------------ vvv haskell-formatter vvv +myBinding + = [[[LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v, + LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v, + LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v, + LeguEosb i4 (v5 - i4) oieha ymuSreje v, + LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v] + + | oyphEmedn <- sdliWmguje, oieha <- ohzvIp] + + | v5 < j6, sdliWmguje <- zedoaregeuKilb tua1, + ohzvIp <- zedoaregeuKilb (0 - loy2)] +-------------------------------------------------------------------------------- +~~~~ + +## tricky full line usage + +~~~~.hs +-- 10 20 30 40 50 60 70 80 +--------------------------------------------------------------- vvv brittany vvv +mybinding = RH.performEvent_ $ postBuild <&> \() -> liftIO $ do + runMaybeT postCliInit >>= \case + Nothing -> return () + Just () -> do + _ <- forkIO $ postCliInitAsync `catch` \(e :: SomeException) -> + writeLogS LogLevelError (show e) + return () +---------------------------------------------------------------- vvv hindent vvv +mybinding = + RH.performEvent_ $ + postBuild <&> \() -> + liftIO $ do + runMaybeT postCliInit >>= \case + Nothing -> return () + Just () -> do + _ <- + forkIO $ + postCliInitAsync `catch` \(e :: SomeException) -> + writeLogS LogLevelError (show e) + return () +------------------------------------------------------ vvv haskell-formatter vvv +mybinding + = RH.performEvent_ $ + postBuild <&> + \ () -> + liftIO $ + do runMaybeT postCliInit >>= + \case + Nothing -> return () + Just () -> do _ <- forkIO $ + postCliInitAsync `catch` + \ (e :: SomeException) -> + writeLogS LogLevelError (show e) + return () +-------------------------------------------------------------------------------- +~~~~ + +## long type signature + +~~~~.hs +-- 10 20 30 40 50 60 70 80 +--------------------------------------------------------------- vvv brittany vvv +linewise + :: forall n t + . (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t)) + => ( R.Event t Text -- command string executed by user + -> R.Dynamic t (Maybe Text, Int, Text) + -> R.Behavior t (Seq Text) -- history + -> R.Event t () -- post-shutdown + -> RH.AppHost + t + ( R.Event t () -- shutdown trigger + , R.Behavior t String -- tab-completion value + , R.Dynamic t (Widget n) + ) + ) + -> RH.AppHost t () +---------------------------------------------------------------- vvv hindent vvv +-- (overflowing columns) +linewise :: + forall n t. + (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t)) + => (R.Event t Text -- command string executed by user + -> R.Dynamic t (Maybe Text, Int, Text) -> R.Behavior t (Seq Text) -- history + -> R.Event t () -- post-shutdown + -> RH.AppHost t ( R.Event t () -- shutdown trigger + , R.Behavior t String -- tab-completion value + , R.Dynamic t (Widget n))) + -> RH.AppHost t () +------------------------------------------------------ vvv haskell-formatter vvv +linewise :: + forall n t . + (Ord n, R.ReflexHost t, MonadIO (R.PushM t), + MonadIO (R.HostFrame t)) => + (R.Event t Text -> + -- command string executed by user + R.Dynamic t (Maybe Text, Int, Text) -> + R.Behavior t (Seq Text) -> + -- history + R.Event t () -> + -- post-shutdown + RH.AppHost t + -- shutdown trigger + (R.Event t (), R.Behavior t String, + -- tab-completion value + R.Dynamic t (Widget n))) + + -> RH.AppHost t () +-------------------------------------------------------------------------------- +~~~~ + +## slighly longer mix of different constructs + +~~~~.hs +-- 10 20 30 40 50 60 70 80 +--------------------------------------------------------------- vvv brittany vvv +completion :: String -> CommandDesc a -> String -> String +completion cmdline desc pcRest = + List.drop (List.length lastWord) $ case choices of + [] -> "" + (c1:cr) -> + headDef "" + $ filter (\s -> List.all (s`isPrefixOf`) cr) + $ reverse + $ List.inits c1 + where + nameDesc = case _cmd_mParent desc of + Nothing -> desc + Just (_, parent) | null pcRest -> parent + Just{} -> desc + lastWord = reverse $ takeWhile (not . isSpace) $ reverse $ cmdline + choices = join + [ [ r + | Just r <- Foldable.toList (_cmd_children nameDesc) + <&> \(s, _) -> [ s | lastWord `isPrefixOf` s ] + ] + , [ s + | s <- transPartDesc =<< _cmd_parts nameDesc + , lastWord `isPrefixOf` s + ] + ] + transPartDesc :: PartDesc -> [String] + transPartDesc = \case + PartLiteral s -> [s] + PartVariable _ -> [] + PartOptional x -> transPartDesc x + PartAlts alts -> alts >>= transPartDesc + PartSeq [] -> [] + PartSeq (x:_) -> transPartDesc x + PartDefault _ x -> transPartDesc x + PartSuggestion ss x -> ss ++ transPartDesc x + PartRedirect _ x -> transPartDesc x + PartReorder xs -> xs >>= transPartDesc + PartMany x -> transPartDesc x + PartWithHelp _h x -> transPartDesc x +---------------------------------------------------------------- vvv hindent vvv +completion :: String -> CommandDesc a -> String -> String +completion cmdline desc pcRest = + List.drop (List.length lastWord) $ + case choices of + [] -> "" + (c1:cr) -> + headDef "" $ + filter (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1 + where + nameDesc = + case _cmd_mParent desc of + Nothing -> desc + Just (_, parent) + | null pcRest -> parent + Just {} -> desc + lastWord = reverse $ takeWhile (not . isSpace) $ reverse $ cmdline + choices = + join + [ [ r + | Just r <- + Foldable.toList (_cmd_children nameDesc) <&> \(s, _) -> + [s | lastWord `isPrefixOf` s] + ] + , [ s + | s <- transPartDesc =<< _cmd_parts nameDesc + , lastWord `isPrefixOf` s + ] + ] + transPartDesc :: PartDesc -> [String] + transPartDesc = + \case + PartLiteral s -> [s] + PartVariable _ -> [] + PartOptional x -> transPartDesc x + PartAlts alts -> alts >>= transPartDesc + PartSeq [] -> [] + PartSeq (x:_) -> transPartDesc x + PartDefault _ x -> transPartDesc x + PartSuggestion ss x -> ss ++ transPartDesc x + PartRedirect _ x -> transPartDesc x + PartReorder xs -> xs >>= transPartDesc + PartMany x -> transPartDesc x + PartWithHelp _h x -> transPartDesc x +------------------------------------------------------ vvv haskell-formatter vvv +completion :: String -> CommandDesc a -> String -> String +completion cmdline desc pcRest + = List.drop (List.length lastWord) $ + case choices of + [] -> "" + (c1 : cr) -> headDef "" $ + filter (\ s -> List.all (s `isPrefixOf`) cr) $ + reverse $ List.inits c1 + + where nameDesc + = case _cmd_mParent desc of + Nothing -> desc + Just (_, parent) | null pcRest -> parent + Just{} -> desc + lastWord = reverse $ takeWhile (not . isSpace) $ reverse $ cmdline + choices + = join + [[r | + Just r <- Foldable.toList (_cmd_children nameDesc) <&> + \ (s, _) -> [s | lastWord `isPrefixOf` s]], + + [s | s <- transPartDesc =<< _cmd_parts nameDesc, + lastWord `isPrefixOf` s]] + + transPartDesc :: PartDesc -> [String] + transPartDesc + = \case + PartLiteral s -> [s] + PartVariable _ -> [] + PartOptional x -> transPartDesc x + PartAlts alts -> alts >>= transPartDesc + PartSeq [] -> [] + PartSeq (x : _) -> transPartDesc x + PartDefault _ x -> transPartDesc x + PartSuggestion ss x -> ss ++ transPartDesc x + PartRedirect _ x -> transPartDesc x + PartReorder xs -> xs >>= transPartDesc + PartMany x -> transPartDesc x + PartWithHelp _h x -> transPartDesc x +-------------------------------------------------------------------------------- +~~~~ + +## another long example; full module + +~~~~.hs +-- 10 20 30 40 50 60 70 80 +--------------------------------------------------------------- vvv brittany vvv +module Language.Haskell.Brittany.BriLayouter + ( layoutBriDoc + ) +where + + + +layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () +layoutBriDoc ast briDoc = do + -- first step: transform the briDoc. + 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 + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyFloating >>= mSet + 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 + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyColumns >>= mSet + 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 + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + + anns :: ExactPrint.Types.Anns <- mAsk + let filteredAnns = filterAnns ast anns + + let state = LayoutState + { _lstate_baseY = 0 + , _lstate_curY = 0 + , _lstate_indLevel = 0 + , _lstate_indLevelLinger = 0 + , _lstate_commentsPrior = extractCommentsPrior filteredAnns + , _lstate_commentsPost = extractCommentsPost filteredAnns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_inhibitMTEL = False + , _lstate_isNewline = NewLineStateInit + } + + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + + let remainingComments = Map.elems (_lstate_commentsPrior state') + ++ Map.elems (_lstate_commentsPost state') + remainingComments + `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst) + + return $ () +---------------------------------------------------------------- vvv hindent vvv +-- (overflowing columns) +module Language.Haskell.Brittany.BriLayouter + ( layoutBriDoc + ) where + +layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () +layoutBriDoc ast briDoc + -- first step: transform the briDoc. + = 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 + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyFloating >>= mSet + 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 + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyColumns >>= mSet + 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 + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + anns :: ExactPrint.Types.Anns <- mAsk + let filteredAnns = filterAnns ast anns + let state = + LayoutState + { _lstate_baseY = 0 + , _lstate_curY = 0 + , _lstate_indLevel = 0 + , _lstate_indLevelLinger = 0 + , _lstate_commentsPrior = extractCommentsPrior filteredAnns + , _lstate_commentsPost = extractCommentsPost filteredAnns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_inhibitMTEL = False + , _lstate_isNewline = NewLineStateInit + } + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + let remainingComments = + Map.elems (_lstate_commentsPrior state') ++ + Map.elems (_lstate_commentsPost state') + remainingComments `forM_` + (mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst) + return $ () +------------------------------------------------------ vvv haskell-formatter vvv +module Language.Haskell.Brittany.BriLayouter (layoutBriDoc) where + +layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM () +layoutBriDoc ast briDoc + -- first step: transform the briDoc. + = 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 + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyFloating >>= mSet + 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 + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyColumns >>= mSet + 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 + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + anns :: ExactPrint.Types.Anns <- mAsk + let filteredAnns = filterAnns ast anns + let state + = LayoutState{_lstate_baseY = 0, _lstate_curY = 0, + _lstate_indLevel = 0, _lstate_indLevelLinger = 0, + _lstate_commentsPrior = + extractCommentsPrior filteredAnns, + _lstate_commentsPost = + extractCommentsPost filteredAnns, + _lstate_commentCol = Nothing, + _lstate_addSepSpace = Nothing, + _lstate_inhibitMTEL = False, + _lstate_isNewline = NewLineStateInit} + + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + let remainingComments + = Map.elems (_lstate_commentsPrior state') ++ + Map.elems (_lstate_commentsPost state') + remainingComments `forM_` + (mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst) + return $ () +~~~~ diff --git a/doc/showcases/Layout_Alignment.md b/doc/showcases/Layout_Alignment.md new file mode 100644 index 0000000..64fec3e --- /dev/null +++ b/doc/showcases/Layout_Alignment.md @@ -0,0 +1,98 @@ +# Horizontal alignment example layouts + +Last updated for brittany version `0.8.0.1`. + +Brittany would layout the following bindings as displayed here. If you change +only the layout of these bindings in some way (e.g. if you initially entered +these without any alignment) and pass it through brittany, you would (again) +get the below versions. + + +#### basic nested alignment example + +~~~~.hs +func (MyLongFoo abc def) = 1 +func (Bar a d ) = 2 +func _ = 3 +~~~~ + +#### alignment of function args and monadcomp bindings + +~~~~.hs +myBinding = + [ [ [ LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v + , LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v + , LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v + , LeguEosb i4 (v5 - i4) oieha ymuSreje v + , LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v + ] + | oyphEmedn <- sdliWmguje + , oieha <- ohzvIp + ] + | v5 < j6 + , sdliWmguje <- zedoaregeuKilb tua1 + , ohzvIp <- zedoaregeuKilb (0 - loy2) + ] +~~~~ + +#### pattern matching + +If same number of pattern args, there is sub-alignment. +Types are not inspected in any way for this. + +~~~~.hs +transPartDesc = \case + PartLiteral s -> [s] + PartVariable _ -> [] + PartOptional x -> transPartDesc x + PartAlts alts -> alts >>= transPartDesc + PartSeq [] -> [] + PartSeq (x:_) -> transPartDesc x + PartDefault _ x -> transPartDesc x + PartSuggestion ss x -> ss ++ transPartDesc x + PartRedirect _ x -> transPartDesc x + PartReorder xs -> xs >>= transPartDesc + PartMany x -> transPartDesc x + PartWithHelp _h x -> transPartDesc x +~~~~ + +#### record syntax, field alignment + +~~~~.hs +action = do + startA <- transRelPos start + s1 <- get + modify $ \s2 -> s2 { _ts_sequencePos = Nothing + , _ts_curNote = _ts_curNote s1 + , _ts_curTrans = _ts_curTrans s1 + , _ts_curBar = _ts_curBar s1 + , _ts_curBase = _ts_curBase s1 + } +~~~~ + +#### items that are not single-line break up alignment + +~~~~.hs +action = do + _ <- string "set" + bindId <- onlySpaces *> ((,) <$> getPosition <*> parserIdent) + marg <- onlySpaces *> optionMaybe (char '(' *> parserParamDef <* char ')') + localId <- + onlySpaces *> (optionMaybe $ string "in" *> onlySpaces *> parserIdent) + _ <- onlySpaces *> string "=" + expr <- spaces *> parserExpr + pure $ CompNotParseItemBind bindId marg expr localId +~~~~ + +consequently these `<-` are not aligned at all: + +~~~~.hs +action = do + normVal :: Float <- expectParamE + =<< expectDynamic (Text.pack "foldInNormalize") + ResponseNode folderC folderN <- uncurry callBExpectS + =<< getKalinAndParams (Text.pack "foldInFolder") + ResponseNode foldeeC foldeeN <- uncurry callBExpectS + =<< getKalinAndParams (Text.pack "foldInFoldee") + pure $ calc normVal folderC folderN foldeeC foldeeN +~~~~ diff --git a/doc/showcases/Layout_Interactions.md b/doc/showcases/Layout_Interactions.md new file mode 100644 index 0000000..4795e3c --- /dev/null +++ b/doc/showcases/Layout_Interactions.md @@ -0,0 +1,63 @@ +# Syntactical element interaction example layouts + +Last updated for brittany version `0.8.0.1`. + +Brittany would layout the following bindings as displayed here. If you change +only the layout of these bindings in some way (e.g. if some lines overflowed +80 columns) and pass it through brittany, you would again get the below +versions. + + +#### Nested ifs + +~~~~.hs +mybinding = if condition1 + then if condition2 + then if condition3 then 0 else 1 + else if condition3 then 2 else 3 + else 4 +~~~~ + +#### if -> case -> do + +~~~~.hs +mybinding = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putStrErrLn + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False +~~~~ + +#### single line ending with start of do-block + +~~~~.hs +mybinding = RH.performEvent_ $ postBuild <&> \() -> liftIO $ do + runMaybeT postCliInit >>= \case + Nothing -> return () + Just () -> do + _ <- forkIO $ postCliInitAsync `catch` \(e :: SomeException) -> + writeLogS LogLevelError (show e) + return () +~~~~ + +#### record-syntax + do-block + +~~~~.hs +myBinding = Booh + { booh_id = name + , booh_parser = name + , booh_query = someLongFunction name ["thingy"] $ do + cps <- zu (Text.pack "thingy") + SampleRate sri <- askConfig' conf_defaultSampleRate + buildLinearState myBinding [cps] + } +~~~~ + diff --git a/doc/showcases/Layout_Types.md b/doc/showcases/Layout_Types.md new file mode 100644 index 0000000..d34ca14 --- /dev/null +++ b/doc/showcases/Layout_Types.md @@ -0,0 +1,65 @@ +# Example type signature layouts + +Last updated for brittany version `0.8.0.1`. + +Brittany would layout the following signatures as displayed here. If you change +only the layout of these signatures in some way (e.g. if you initially entered +them as one-liners) and pass it through brittany, you would (again) get the +below versions. + +~~~~.hs +docExt + :: (ExactPrint.Annotate.Annotate ast) + => Located ast + -> ExactPrint.Types.Anns + -> Bool + -> ToBriDocM BriDocNumbered +~~~~ + +~~~~.hs +processDefault + :: ( ExactPrint.Annotate.Annotate ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiReader ExactPrint.Types.Anns m + ) + => Located ast + -> m () +~~~~ + +~~~~.hs +linewise + :: forall n t + . (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t)) + => ( R.Event t Text -- command string executed by user + -> R.Dynamic t (Maybe Text, Int, Text) + -> R.Behavior t (Seq Text) -- history + -> R.Event t () -- post-shutdown + -> RH.AppHost + t + ( R.Event t () -- shutdown trigger + , R.Behavior t String -- tab-completion value + , R.Dynamic t (Widget n) + ) + ) + -> RH.AppHost t () +~~~~ + +linewise :: + forall n t. + (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t)) + => (R.Event t Text -- command string executed by user + -> R.Dynamic t (Maybe Text, Int, Text) -> R.Behavior t (Seq Text) -- history + -> R.Event t () -- post-shutdown + -> RH.AppHost t ( R.Event t () -- shutdown trigger + , R.Behavior t String -- tab-completion value + , R.Dynamic t (Widget n))) + -> RH.AppHost t () + + +processDefault :: + ( ExactPrint.Annotate.Annotate ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiReader ExactPrint.Types.Anns m + ) + => Located ast + -> m () diff --git a/doc/showcases/Parser.md b/doc/showcases/Parser.md new file mode 100644 index 0000000..cfb081d --- /dev/null +++ b/doc/showcases/Parser.md @@ -0,0 +1,168 @@ + +### Input + +contains some very long lines and strange formatting of the +list/monad-comprehension: + +~~~~.hs +parseCalUnits :: forall m . (MonadMultiReader ParserWrapperGuard m, MonadMultiState ParserFileCache m, MonadIO m) => [GenericParser] -> [FilePath] -> m (Either Text [CalUnit]) +parseCalUnits parsers inputs = fmap (fmap join . sequence) $ inputs `forM` \path -> do + readCachedFile path (\raw -> parseChunks $ createChunks $ (Text.pack path, raw)) + where + + createChunks :: (Text, Text) -> [(Text, [(Int, InputLine)])] + createChunks (file, input) = fmap ((,) file) $ groupBy (\a b -> grouper (snd a) (snd b)) $ dropWhile (lineIsSpace . snd) $ zip [1 ..] $ lineMapper <$> Text.lines input + where + headerParser :: Parser (Text, Bool, Text) + headerParser = + [ (Text.pack name, isMain, Text.pack typ) + | _ <- string "node", _ <- many1 $ oneOf " \t", + isMain <- fmap isJust $ optionMaybe (string "*" *> many1 (oneOf " \t")), + name <- many1 $ noneOf " \t\r\n:", + _ <- many $ oneOf " \t", + _ <- char ':', + _ <- many $ oneOf " \t", + typ <- many1 $ satisfy $ not . isSpace, + _ <- many $ oneOf " \t", + _ <- eof ] + lineMapper :: Text -> InputLine + lineMapper line = case runParser headerParser () "" line of + Left _e -> NormalLine line + Right (n, m, t) -> HeaderLine n m t + lineIsSpace :: InputLine -> Bool + lineIsSpace (NormalLine x) = Text.null $ Text.strip x + lineIsSpace _ = False + grouper :: InputLine -> InputLine -> Bool + grouper _ HeaderLine{} = False + grouper _ _ = True + + parseChunks :: [(Text, [(Int, InputLine)])] -> m (Either Text [CalUnit]) + parseChunks nodes = runEitherT $ sequence (uncurry parseNode <$> nodes) + where + findParser :: Text -> Maybe GenericParser + findParser pid = find (\(GenericParser p) -> parser_ident p == pid) parsers + parseNode :: Text -> [(Int, InputLine)] -> EitherT Text m CalUnit + parseNode file ((n, HeaderLine name isMain typ):rlines) = do + (GenericParser p) <- case findParser typ of + Nothing -> left $ Text.pack "could not find parser for node \"" <> name <> Text.pack "\" of type \"" <> typ <> Text.pack "\" at " <> file <> Text.pack (": " ++ show n ++ ".") + Just x -> return x + let firstLine = fromMaybe 0 $ fst <$> listToMaybe rlines + ParserDataStore dstore version <- _pfc_store <$> mGet + let postfix = Text.pack "\n(When parsing node \"" <> name <> Text.pack "\")" + parsed <- bimapEitherT (<>postfix) id $ hoistEither $ parser_parse p file firstLine $ Text.unlines $ [ fst $ Text.breakOn (Text.pack "--") line | (_, NormalLine line) <- rlines ] + let oldDat = case M.lookup name dstore of + Nothing -> parser_zero p $> version + Just s -> case decodeOrFail s of + Right (rest, _, decoded) | BSL.null rest -> decoded + _ -> parser_zero p $> version + let (newDat, delta) = parser_diff p version oldDat (parsed $> version) + pfc <- mGet + mSet $ pfc { _pfc_store = ParserDataStore (M.insert name (encode newDat) dstore) version } + let calUnit = parser_build p version name (newDat, delta) + return $ CalUnit isMain calUnit + parseNode file ((n, _):_) = left $ Text.pack "expected node definition at " <> file <> Text.pack (": " ++ show n ++ ".") + parseNode file _ = left $ Text.pack "expected node definition at " <> file <> Text.pack "." +~~~~.hs + +### Brittany 0.8.0.1 output on default settings + +~~~~.hs +parseCalUnits + :: forall m + . ( MonadMultiReader ParserWrapperGuard m + , MonadMultiState ParserFileCache m + , MonadIO m + ) + => [GenericParser] + -> [FilePath] + -> m (Either Text [CalUnit]) +parseCalUnits parsers inputs = + fmap (fmap join . sequence) $ inputs `forM` \path -> do + readCachedFile + path + (\raw -> parseChunks $ createChunks $ (Text.pack path, raw)) + where + + createChunks :: (Text, Text) -> [(Text, [(Int, InputLine)])] + createChunks (file, input) = + fmap ((,) file) + $ groupBy (\a b -> grouper (snd a) (snd b)) + $ dropWhile (lineIsSpace . snd) + $ zip [1 ..] + $ lineMapper + <$> Text.lines input + where + headerParser :: Parser (Text, Bool, Text) + headerParser = + [ (Text.pack name, isMain, Text.pack typ) + | _ <- string "node" + , _ <- many1 $ oneOf " \t" + , isMain <- fmap isJust $ optionMaybe (string "*" *> many1 (oneOf " \t")) + , name <- many1 $ noneOf " \t\r\n:" + , _ <- many $ oneOf " \t" + , _ <- char ':' + , _ <- many $ oneOf " \t" + , typ <- many1 $ satisfy $ not . isSpace + , _ <- many $ oneOf " \t" + , _ <- eof + ] + lineMapper :: Text -> InputLine + lineMapper line = case runParser headerParser () "" line of + Left _e -> NormalLine line + Right (n, m, t) -> HeaderLine n m t + lineIsSpace :: InputLine -> Bool + lineIsSpace (NormalLine x) = Text.null $ Text.strip x + lineIsSpace _ = False + grouper :: InputLine -> InputLine -> Bool + grouper _ HeaderLine{} = False + grouper _ _ = True + + parseChunks :: [(Text, [(Int, InputLine)])] -> m (Either Text [CalUnit]) + parseChunks nodes = runEitherT $ sequence (uncurry parseNode <$> nodes) + where + findParser :: Text -> Maybe GenericParser + findParser pid = find (\(GenericParser p) -> parser_ident p == pid) parsers + parseNode :: Text -> [(Int, InputLine)] -> EitherT Text m CalUnit + parseNode file ((n, HeaderLine name isMain typ):rlines) = do + (GenericParser p) <- case findParser typ of + Nothing -> + left + $ Text.pack "could not find parser for node \"" + <> name + <> Text.pack "\" of type \"" + <> typ + <> Text.pack "\" at " + <> file + <> Text.pack (": " ++ show n ++ ".") + Just x -> return x + let firstLine = fromMaybe 0 $ fst <$> listToMaybe rlines + ParserDataStore dstore version <- _pfc_store <$> mGet + let postfix = + Text.pack "\n(When parsing node \"" <> name <> Text.pack "\")" + parsed <- + bimapEitherT (<>postfix) id + $ hoistEither + $ parser_parse p file firstLine + $ Text.unlines + $ [ fst $ Text.breakOn (Text.pack "--") line + | (_, NormalLine line) <- rlines + ] + let oldDat = case M.lookup name dstore of + Nothing -> parser_zero p $> version + Just s -> case decodeOrFail s of + Right (rest, _, decoded) | BSL.null rest -> decoded + _ -> parser_zero p $> version + let (newDat, delta) = parser_diff p version oldDat (parsed $> version) + pfc <- mGet + mSet $ pfc + { _pfc_store = ParserDataStore (M.insert name (encode newDat) dstore) + version + } + let calUnit = parser_build p version name (newDat, delta) + return $ CalUnit isMain calUnit + parseNode file ((n, _):_) = + left $ Text.pack "expected node definition at " <> file <> Text.pack + (": " ++ show n ++ ".") + parseNode file _ = + left $ Text.pack "expected node definition at " <> file <> Text.pack "." +~~~~