hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Merge pull request #132 from sergv/master 

Fix some hlint suggestions and Replace docAltFilter
pull/136/head
Lennart Spitzner 2018-04-04 06:50:48 +02:00 committed by GitHub
parent b43ee43220 7ffa58976f
commit 24886e818a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 750 additions and 762 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
.hlint.yaml Normal file
View File

@ -0,0 +1,24 @@
# HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
# This file contains a template configuration file, which is typically
# placed as .hlint.yaml in the root of your project
# Specify additional command line arguments
- arguments:
[ "--cpp-include=srcinc"
, "--language=GADTs"
, "--language=LambdaCase"
, "--language=MultiWayIf"
, "--language=KindSignatures"
, "--cross"
, "--threads=0"
]
- ignore: {name: "Use camelCase"}
- ignore: {name: "Redundant as"}
- ignore: {name: "Redundant do"}
- ignore: {name: "Redundant return"}
- ignore: {name: "Redundant guard", whithin: "lrdrNameToTextAnn"}

3
brittany.cabal
View File

@ -244,7 +244,6 @@ test-suite unittests
, ghc-boot-th , ghc-boot-th
, hspec >=2.4.1 && <2.5 , hspec >=2.4.1 && <2.5
} }
ghc-options: -Wall
main-is: TestMain.hs main-is: TestMain.hs
other-modules: TestUtils other-modules: TestUtils
AsymptoticPerfTests AsymptoticPerfTests
@ -314,7 +313,6 @@ test-suite littests
, filepath , filepath
, parsec >=3.1.11 && <3.2 , parsec >=3.1.11 && <3.2
} }
ghc-options: -Wall
main-is: Main.hs main-is: Main.hs
other-modules: other-modules:
hs-source-dirs: src-literatetests hs-source-dirs: src-literatetests
@ -355,7 +353,6 @@ test-suite libinterfacetests
, transformers , transformers
, hspec >=2.4.1 && <2.5 , hspec >=2.4.1 && <2.5
} }
ghc-options: -Wall
main-is: Main.hs main-is: Main.hs
other-modules: other-modules:
hs-source-dirs: src-libinterfacetests hs-source-dirs: src-libinterfacetests

3
src-brittany/Main.hs
View File

@ -11,6 +11,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Monoid
import Text.Read (Read(..)) import Text.Read (Read(..))
import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.ParserCombinators.ReadP as ReadP
@ -148,7 +149,7 @@ mainCmdParser helpDesc = do
, PP.text "inplace: override respective input file (without backup!)" , PP.text "inplace: override respective input file (without backup!)"
] ]
) )
<> flagDefault Display Data.Monoid.<> flagDefault Display
) )
inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files") inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files")
reorderStop reorderStop

4
src/Language/Haskell/Brittany/Internal.hs
View File

@ -93,8 +93,8 @@ parsePrintModule configRaw inputText = runExceptT $ do
cppCheckFunc cppCheckFunc
(hackTransform $ Text.unpack inputText) (hackTransform $ Text.unpack inputText)
case parseResult of case parseResult of
Left err -> throwE $ [ErrorInput err] Left err -> throwE [ErrorInput err]
Right x -> pure $ x Right x -> pure x
(errsWarns, outputTextL) <- do (errsWarns, outputTextL) <- do
let omitCheck = let omitCheck =
config config

59
src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Haskell.Brittany.Internal.LayouterBasics module Language.Haskell.Brittany.Internal.LayouterBasics
( processDefault ( processDefault
, rdrNameToText , rdrNameToText
@ -11,7 +13,10 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, docEmpty , docEmpty
, docLit , docLit
, docAlt , docAlt
, docAltFilter , CollectAltM
, addAlternativeCond
, addAlternative
, runFilteredAlternative
, docLines , docLines
, docCols , docCols
, docSeq , docSeq
@ -60,6 +65,8 @@ where
#include "prelude.inc" #include "prelude.inc"
import qualified Control.Monad.Writer.Strict as Writer
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
@ -111,7 +118,7 @@ processDefault x = do
-- the module (header). This would remove the need for this hack! -- the module (header). This would remove the need for this hack!
case str of case str of
"\n" -> return () "\n" -> return ()
_ -> mTell $ Text.Builder.fromString $ str _ -> mTell $ Text.Builder.fromString str
-- | Use ExactPrint's output for this node; add a newly generated inline comment -- | 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 -- at insertion position (meant to point out to the user that this node is
@ -166,7 +173,7 @@ briDocByExactInlineOnly infoStr ast = do
False False
t t
let errorAction = do let errorAction = do
mTell $ [ErrorUnknownNode infoStr ast] mTell [ErrorUnknownNode infoStr ast]
docLit docLit
$ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
case (fallbackMode, Text.lines exactPrinted) of case (fallbackMode, Text.lines exactPrinted) of
@ -256,8 +263,8 @@ extractAllComments ann =
) )
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast anns = filterAnns ast =
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) = do hasAnyCommentsBelow ast@(L l _) = do
@ -415,8 +422,20 @@ docExt x anns shouldAddComment = allocateNode $ BDFExternal
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docAlt l = allocateNode . BDFAlt =<< sequence l docAlt l = allocateNode . BDFAlt =<< sequence l
docAltFilter :: [(Bool, ToBriDocM BriDocNumbered)] -> ToBriDocM BriDocNumbered newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
docAltFilter = docAlt . map snd . filter fst deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc =
when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative =
CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) =
docAlt $ Writer.execWriter action
docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
@ -565,7 +584,7 @@ instance DocWrapable a => DocWrapable [a] where
docWrapNode ast bdsm = do docWrapNode ast bdsm = do
bds <- bdsm bds <- bdsm
case bds of case bds of
[] -> return $ [] -- TODO: this might be bad. maybe. then again, not really. well. [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well.
[bd] -> do [bd] -> do
bd' <- docWrapNode ast (return bd) bd' <- docWrapNode ast (return bd)
return [bd'] return [bd']
@ -577,23 +596,23 @@ instance DocWrapable a => DocWrapable [a] where
docWrapNodePrior ast bdsm = do docWrapNodePrior ast bdsm = do
bds <- bdsm bds <- bdsm
case bds of case bds of
[] -> return $ [] [] -> return []
(bd1:bdR) -> do (bd1:bdR) -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
return $ (bd1':bdR) return (bd1':bdR)
docWrapNodeRest ast bdsm = do docWrapNodeRest ast bdsm = do
bds <- bdsm bds <- bdsm
case reverse bds of case reverse bds of
[] -> return $ [] [] -> return []
(bdN:bdR) -> do (bdN:bdR) -> do
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse $ (bdN':bdR) return $ reverse (bdN':bdR)
instance DocWrapable a => DocWrapable (Seq a) where instance DocWrapable a => DocWrapable (Seq a) where
docWrapNode ast bdsm = do docWrapNode ast bdsm = do
bds <- bdsm bds <- bdsm
case Seq.viewl bds of case Seq.viewl bds of
Seq.EmptyL -> return $ Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
bd1 Seq.:< rest -> case Seq.viewr rest of bd1 Seq.:< rest -> case Seq.viewr rest of
Seq.EmptyR -> do Seq.EmptyR -> do
bd1' <- docWrapNode ast (return bd1) bd1' <- docWrapNode ast (return bd1)
@ -605,14 +624,14 @@ instance DocWrapable a => DocWrapable (Seq a) where
docWrapNodePrior ast bdsm = do docWrapNodePrior ast bdsm = do
bds <- bdsm bds <- bdsm
case Seq.viewl bds of case Seq.viewl bds of
Seq.EmptyL -> return $ Seq.empty Seq.EmptyL -> return Seq.empty
bd1 Seq.:< bdR -> do bd1 Seq.:< bdR -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
return $ bd1' Seq.<| bdR return $ bd1' Seq.<| bdR
docWrapNodeRest ast bdsm = do docWrapNodeRest ast bdsm = do
bds <- bdsm bds <- bdsm
case Seq.viewr bds of case Seq.viewr bds of
Seq.EmptyR -> return $ Seq.empty Seq.EmptyR -> return Seq.empty
bdR Seq.:> bdN -> do bdR Seq.:> bdN -> do
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ bdR Seq.|> bdN' return $ bdR Seq.|> bdN'
@ -623,19 +642,19 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
if null bds if null bds
then do then do
bd' <- docWrapNode ast (return bd) bd' <- docWrapNode ast (return bd)
return $ (bds, bd', x) return (bds, bd', x)
else do else do
bds' <- docWrapNodePrior ast (return bds) bds' <- docWrapNodePrior ast (return bds)
bd' <- docWrapNodeRest ast (return bd) bd' <- docWrapNodeRest ast (return bd)
return $ (bds', bd', x) return (bds', bd', x)
docWrapNodePrior ast stuffM = do docWrapNodePrior ast stuffM = do
(bds, bd, x) <- stuffM (bds, bd, x) <- stuffM
bds' <- docWrapNodePrior ast (return bds) bds' <- docWrapNodePrior ast (return bds)
return $ (bds', bd, x) return (bds', bd, x)
docWrapNodeRest ast stuffM = do docWrapNodeRest ast stuffM = do
(bds, bd, x) <- stuffM (bds, bd, x) <- stuffM
bd' <- docWrapNodeRest ast (return bd) bd' <- docWrapNodeRest ast (return bd)
return $ (bds, bd', x) return (bds, bd', x)
@ -661,7 +680,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
unknownNodeError unknownNodeError
:: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered
unknownNodeError infoStr ast = do unknownNodeError infoStr ast = do
mTell $ [ErrorUnknownNode infoStr ast] mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]

469
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -308,258 +308,237 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
++ (List.intersperse docCommaSep ++ (List.intersperse docCommaSep
(docForceSingleline . return <$> gs) (docForceSingleline . return <$> gs)
) )
wherePart = case mWhereDocs of
Nothing -> Just docEmpty
Just [w] -> Just $ docSeq
[ docSeparator
, appSep $ docLit $ Text.pack "where"
, docSetIndentLevel $ docForceSingleline $ return w
]
_ -> Nothing
indentPolicy <- mAsk indentPolicy <- mAsk
<&> _conf_layout <&> _conf_layout
.> _lconfig_indentPolicy .> _lconfig_indentPolicy
.> confUnpack .> confUnpack
docAltFilter
$ -- one-line solution runFilteredAlternative $ do
[ ( True
, docCols case clauseDocs of
(ColBindingLine alignmentToken) [(guards, body, _bodyRaw)] -> do
[ docSeq (patPartInline ++ [guardPart]) let guardPart = singleLineGuardsDoc guards
, docSeq forM_ wherePart $ \wherePart' ->
[ appSep $ return binderDoc -- one-line solution
, docForceSingleline $ return body addAlternativeCond (not hasComments) $ docCols
, wherePart (ColBindingLine alignmentToken)
] [ docSeq (patPartInline ++ [guardPart])
] , docSeq
) [ appSep $ return binderDoc
| not hasComments , docForceSingleline $ return body
, [(guards, body, _bodyRaw)] <- [clauseDocs] , wherePart'
, let guardPart = singleLineGuardsDoc guards
, 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)
[ ( True
, docLines
$ [ docCols
(ColBindingLine alignmentToken)
[ docSeq (patPartInline ++ [guardPart])
, docSeq
[appSep $ return binderDoc, docForceParSpacing $ return body]
] ]
] ]
++ wherePartMultiLine -- one-line solution + where in next line(s)
) addAlternativeCond (Data.Maybe.isJust mWhereDocs)
| [(guards, body, _bodyRaw)] <- [clauseDocs] $ docLines
, let guardPart = singleLineGuardsDoc guards $ [ docCols
, Data.Maybe.isJust mWhereDocs (ColBindingLine alignmentToken)
] [ docSeq (patPartInline ++ [guardPart])
++ -- two-line solution + where in next line(s) , docSeq
[ ( True [appSep $ return binderDoc, docForceParSpacing $ return body]
, docLines ]
$ [ docForceSingleline ]
$ docSeq (patPartInline ++ [guardPart, return binderDoc]) ++ wherePartMultiLine
, docEnsureIndent BrIndentRegular $ docForceSingleline $ return body -- two-line solution + where in next line(s)
] addAlternative
++ wherePartMultiLine $ docLines
) $ [ docForceSingleline
| [(guards, body, _bodyRaw)] <- [clauseDocs] $ docSeq (patPartInline ++ [guardPart, return binderDoc])
, let guardPart = singleLineGuardsDoc guards , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body
] ]
++ -- pattern and exactly one clause in single line, body as par; ++ wherePartMultiLine
-- where in following lines -- pattern and exactly one clause in single line, body as par;
[ ( True -- where in following lines
, docLines addAlternative
$ [ docCols $ docLines
(ColBindingLine alignmentToken) $ [ docCols
[ docSeq (patPartInline ++ [guardPart]) (ColBindingLine alignmentToken)
, docSeq [ docSeq (patPartInline ++ [guardPart])
[ appSep $ return binderDoc , docSeq
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body [ appSep $ return binderDoc
] , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
] ]
] ]
-- , lineMod $ docAlt ]
-- [ docSetBaseY $ return body -- , lineMod $ docAlt
-- , docAddBaseY BrIndentRegular $ return body -- [ docSetBaseY $ return body
-- ] -- , docAddBaseY BrIndentRegular $ return body
++ wherePartMultiLine -- ]
) ++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs] -- pattern and exactly one clause in single line, body in new line.
, let guardPart = singleLineGuardsDoc guards addAlternative
] $ docLines
++ -- pattern and exactly one clause in single line, body in new line. $ [ docSeq (patPartInline ++ [guardPart, return binderDoc])
[ ( True , docEnsureIndent BrIndentRegular
, docLines $ docNonBottomSpacing
$ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) $ docAddBaseY BrIndentRegular
, docEnsureIndent BrIndentRegular $ return body
$ docNonBottomSpacing ]
$ (docAddBaseY BrIndentRegular $ return body) ++ wherePartMultiLine
]
++ wherePartMultiLine _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1`
)
| [(guards, body, _)] <- [clauseDocs] case mPatDoc of
, let guardPart = singleLineGuardsDoc guards Nothing -> return ()
] Just patDoc ->
++ -- multiple clauses added in-paragraph, each in a single line -- multiple clauses added in-paragraph, each in a single line
-- example: foo | bar = baz -- example: foo | bar = baz
-- | lll = asd -- | lll = asd
[ ( indentPolicy /= IndentPolicyLeft addAlternativeCond (indentPolicy /= IndentPolicyLeft)
, docLines $ docLines
$ [ docSeq $ [ docSeq
[ appSep $ docForceSingleline $ return patDoc [ appSep $ docForceSingleline $ return patDoc
, docSetBaseY , docSetBaseY
$ docLines $ docLines
$ clauseDocs $ clauseDocs
<&> \(guardDocs, bodyDoc, _) -> do <&> \(guardDocs, bodyDoc, _) -> do
let guardPart = singleLineGuardsDoc guardDocs let guardPart = singleLineGuardsDoc guardDocs
-- the docForceSingleline might seems superflous, but it -- the docForceSingleline might seems superflous, but it
-- helps the alternative resolving impl. -- helps the alternative resolving impl.
docForceSingleline $ docCols docForceSingleline $ docCols
ColGuardedBody ColGuardedBody
[ guardPart [ guardPart
, docSeq , docSeq
[ appSep $ return binderDoc
, docForceSingleline $ return bodyDoc
-- i am not sure if there is a benefit to using
-- docForceParSpacing additionally here:
-- , docAddBaseY BrIndentRegular $ return bodyDoc
]
]
]
]
++ wherePartMultiLine
)
| Just patDoc <- [mPatDoc]
]
++ -- multiple clauses, each in a separate, single line
[ ( True
, docLines
$ [ docAddBaseY BrIndentRegular
$ patPartParWrap
$ docLines
$ map docSetBaseY
$ clauseDocs
<&> \(guardDocs, bodyDoc, _) -> do
let guardPart = singleLineGuardsDoc guardDocs
-- the docForceSingleline might seems superflous, but it
-- helps the alternative resolving impl.
docForceSingleline $ docCols
ColGuardedBody
[ guardPart
, docSeq
[ appSep $ return binderDoc
, docForceSingleline $ return bodyDoc
-- i am not sure if there is a benefit to using
-- docForceParSpacing additionally here:
-- , docAddBaseY BrIndentRegular $ return bodyDoc
]
]
]
++ wherePartMultiLine
)
]
++ -- multiple clauses, each with the guard(s) in a single line, body
-- as a paragraph
[ ( True
, docLines
$ [ docAddBaseY BrIndentRegular
$ patPartParWrap
$ docLines
$ map docSetBaseY
$ clauseDocs
<&> \(guardDocs, bodyDoc, _) ->
docSeq
$ ( case guardDocs of
[] -> []
[g] ->
[ docForceSingleline
$ docSeq [appSep $ docLit $ Text.pack "|", return g]
]
gs ->
[ docForceSingleline
$ docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs)
]
)
++ [ docSeparator
, docCols
ColOpPrefix
[ appSep $ return binderDoc
, docAddBaseY BrIndentRegular
$ docForceParSpacing
$ return bodyDoc
]
]
]
++ wherePartMultiLine
)
]
++ -- multiple clauses, each with the guard(s) in a single line, body
-- in a new line as a paragraph
[ ( True
, docLines
$ [ docAddBaseY BrIndentRegular
$ patPartParWrap
$ docLines
$ map docSetBaseY
$ clauseDocs
>>= \(guardDocs, bodyDoc, _) ->
( case guardDocs of
[] -> []
[g] ->
[ docForceSingleline
$ docSeq [appSep $ docLit $ Text.pack "|", return g]
]
gs ->
[ docForceSingleline
$ docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs)
]
)
++ [ docCols
ColOpPrefix
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docAddBaseY BrIndentRegular , docForceSingleline $ return bodyDoc
$ docForceParSpacing -- i am not sure if there is a benefit to using
$ return bodyDoc -- docForceParSpacing additionally here:
-- , docAddBaseY BrIndentRegular $ return bodyDoc
] ]
] ]
] ]
++ wherePartMultiLine ]
) ++ wherePartMultiLine
] -- multiple clauses, each in a separate, single line
++ -- conservative approach: everything starts on the left. addAlternative
[ ( True $ docLines
, docLines $ [ docAddBaseY BrIndentRegular
$ [ docAddBaseY BrIndentRegular $ patPartParWrap
$ patPartParWrap $ docLines
$ docLines $ map docSetBaseY
$ map docSetBaseY $ clauseDocs
$ clauseDocs <&> \(guardDocs, bodyDoc, _) -> do
>>= \(guardDocs, bodyDoc, _) -> let guardPart = singleLineGuardsDoc guardDocs
( case guardDocs of -- the docForceSingleline might seems superflous, but it
[] -> [] -- helps the alternative resolving impl.
[g] -> docForceSingleline $ docCols
[docSeq [appSep $ docLit $ Text.pack "|", return g]] ColGuardedBody
(g1:gr) -> [ guardPart
( docSeq [appSep $ docLit $ Text.pack "|", return g1] , docSeq
: ( gr [ appSep $ return binderDoc
<&> \g -> , docForceSingleline $ return bodyDoc
docSeq -- i am not sure if there is a benefit to using
[appSep $ docLit $ Text.pack ",", return g] -- docForceParSpacing additionally here:
) -- , docAddBaseY BrIndentRegular $ return bodyDoc
) ]
) ]
++ [ docCols ]
ColOpPrefix ++ wherePartMultiLine
[ appSep $ return binderDoc -- multiple clauses, each with the guard(s) in a single line, body
, docAddBaseY BrIndentRegular $ return bodyDoc -- as a paragraph
] addAlternative
] $ docLines
] $ [ docAddBaseY BrIndentRegular
++ wherePartMultiLine $ patPartParWrap
) $ docLines
] $ map docSetBaseY
$ clauseDocs
<&> \(guardDocs, bodyDoc, _) ->
docSeq
$ ( case guardDocs of
[] -> []
[g] ->
[ docForceSingleline
$ docSeq [appSep $ docLit $ Text.pack "|", return g]
]
gs ->
[ docForceSingleline
$ docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs)
]
)
++ [ docSeparator
, docCols
ColOpPrefix
[ appSep $ return binderDoc
, docAddBaseY BrIndentRegular
$ docForceParSpacing
$ return bodyDoc
]
]
]
++ wherePartMultiLine
-- multiple clauses, each with the guard(s) in a single line, body
-- in a new line as a paragraph
addAlternative
$ docLines
$ [ docAddBaseY BrIndentRegular
$ patPartParWrap
$ docLines
$ map docSetBaseY
$ clauseDocs
>>= \(guardDocs, bodyDoc, _) ->
( case guardDocs of
[] -> []
[g] ->
[ docForceSingleline
$ docSeq [appSep $ docLit $ Text.pack "|", return g]
]
gs ->
[ docForceSingleline
$ docSeq
$ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs)
]
)
++ [ docCols
ColOpPrefix
[ appSep $ return binderDoc
, docAddBaseY BrIndentRegular
$ docForceParSpacing
$ return bodyDoc
]
]
]
++ wherePartMultiLine
-- conservative approach: everything starts on the left.
addAlternative
$ docLines
$ [ docAddBaseY BrIndentRegular
$ patPartParWrap
$ docLines
$ map docSetBaseY
$ clauseDocs
>>= \(guardDocs, bodyDoc, _) ->
( case guardDocs of
[] -> []
[g] ->
[docSeq [appSep $ docLit $ Text.pack "|", return g]]
(g1:gr) ->
( docSeq [appSep $ docLit $ Text.pack "|", return g1]
: ( gr
<&> \g ->
docSeq
[appSep $ docLit $ Text.pack ",", return g]
)
)
)
++ [ docCols
ColOpPrefix
[ appSep $ return binderDoc
, docAddBaseY BrIndentRegular $ return bodyDoc
]
]
]
++ wherePartMultiLine

671
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

@ -61,7 +61,7 @@ layoutExpr lexpr@(L _ expr) = do
bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body
let funcPatternPartLine = let funcPatternPartLine =
docCols ColCasePattern docCols ColCasePattern
$ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
docAlt docAlt
[ -- single line [ -- single line
docSeq docSeq
@ -106,7 +106,7 @@ layoutExpr lexpr@(L _ expr) = do
#else /* ghc-8.0 */ #else /* ghc-8.0 */
HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do
#endif #endif
binderDoc <- docLit $ Text.pack "->" binderDoc <- docLit $ Text.pack "->"
funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "\\case") (docLit $ Text.pack "\\case")
@ -114,8 +114,8 @@ layoutExpr lexpr@(L _ expr) = do
HsApp exp1@(L _ HsApp{}) exp2 -> do HsApp exp1@(L _ HsApp{}) exp2 -> do
let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName])
gather list = \case gather list = \case
(L _ (HsApp l r)) -> gather (r:list) l L _ (HsApp l r) -> gather (r:list) l
x -> (x, list) x -> (x, list)
let (headE, paramEs) = gather [exp2] exp1 let (headE, paramEs) = gather [exp2] exp1
let colsOrSequence = case headE of let colsOrSequence = case headE of
L _ (HsVar (L _ (Unqual occname))) -> L _ (HsVar (L _ (Unqual occname))) ->
@ -123,51 +123,46 @@ layoutExpr lexpr@(L _ expr) = do
_ -> docSeq _ -> docSeq
headDoc <- docSharedWrapper layoutExpr headE headDoc <- docSharedWrapper layoutExpr headE
paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs
docAltFilter runFilteredAlternative $ do
[ -- foo x y -- foo x y
( True addAlternative
, colsOrSequence $ colsOrSequence
$ appSep (docForceSingleline headDoc) $ appSep (docForceSingleline headDoc)
: spacifyDocs (docForceSingleline <$> paramDocs) : spacifyDocs (docForceSingleline <$> paramDocs)
) -- foo x
, -- foo x -- y
-- y addAlternativeCond allowFreeIndent
( allowFreeIndent $ docSeq
, docSeq [ appSep (docForceSingleline headDoc)
[ appSep (docForceSingleline headDoc) , docSetBaseY
, docSetBaseY $ docAddBaseY BrIndentRegular
$ docAddBaseY BrIndentRegular $ docLines
$ docLines $ docForceSingleline <$> paramDocs
$ (docForceSingleline <$> paramDocs) ]
] -- foo
) -- x
, -- foo -- y
-- x addAlternative
-- y $ docSetParSpacing
( True
, docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar
(docForceSingleline headDoc) (docForceSingleline headDoc)
( docNonBottomSpacing ( docNonBottomSpacing
$ docLines paramDocs $ docLines paramDocs
) )
) -- ( multi
, -- ( multi -- line
-- line -- function
-- function -- )
-- ) -- x
-- x -- y
-- y addAlternative
( True $ docAddBaseY BrIndentRegular
, docAddBaseY BrIndentRegular
$ docPar $ docPar
headDoc headDoc
( docNonBottomSpacing ( docNonBottomSpacing
$ docLines paramDocs $ docLines paramDocs
) )
)
]
HsApp exp1 exp2 -> do HsApp exp1 exp2 -> do
-- TODO: if expDoc1 is some literal, we may want to create a docCols here. -- TODO: if expDoc1 is some literal, we may want to create a docCols here.
expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc1 <- docSharedWrapper layoutExpr exp1
@ -235,47 +230,44 @@ layoutExpr lexpr@(L _ expr) = do
| xD <- docSharedWrapper layoutExpr x | xD <- docSharedWrapper layoutExpr x
, yD <- docSharedWrapper layoutExpr y , yD <- docSharedWrapper layoutExpr y
] ]
opLastDoc <- docSharedWrapper layoutExpr expOp opLastDoc <- docSharedWrapper layoutExpr expOp
expLastDoc <- docSharedWrapper layoutExpr expRight expLastDoc <- docSharedWrapper layoutExpr expRight
hasComments <- hasAnyCommentsBelow lexpr hasComments <- hasAnyCommentsBelow lexpr
let allowPar = case (expOp, expRight) of let allowPar = case (expOp, expRight) of
(L _ (HsVar (L _ (Unqual occname))), _) (L _ (HsVar (L _ (Unqual occname))), _)
| occNameString occname == "$" -> True | occNameString occname == "$" -> True
(_, L _ (HsApp _ (L _ HsVar{}))) -> False (_, L _ (HsApp _ (L _ HsVar{}))) -> False
_ -> True _ -> True
docAltFilter runFilteredAlternative $ do
[ ( not hasComments addAlternativeCond (not hasComments)
$ docSeq
[ appSep $ docForceSingleline leftOperandDoc
, docSeq , docSeq
[ appSep $ docForceSingleline leftOperandDoc $ appListDocs <&> \(od, ed) -> docSeq
, docSeq [ appSep $ docForceSingleline od
$ (appListDocs <&> \(od, ed) -> docSeq , appSep $ docForceSingleline ed
[ appSep $ docForceSingleline od ]
, appSep $ docForceSingleline ed , appSep $ docForceSingleline opLastDoc
] , (if allowPar then docForceParSpacing else docForceSingleline)
) expLastDoc
, appSep $ docForceSingleline opLastDoc ]
, (if allowPar then docForceParSpacing else docForceSingleline)
expLastDoc
]
)
-- this case rather leads to some unfortunate layouting than to anything -- this case rather leads to some unfortunate layouting than to anything
-- useful; disabling for now. (it interfers with cols stuff.) -- useful; disabling for now. (it interfers with cols stuff.)
-- , docSetBaseY -- addAlternative
-- - $ docPar -- $ docSetBaseY
-- $ docPar
-- leftOperandDoc -- leftOperandDoc
-- ( docLines -- ( docLines
-- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
-- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
-- ) -- )
, (otherwise addAlternative $
, docPar docPar
leftOperandDoc leftOperandDoc
( docLines ( docLines
$ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
) )
)
]
OpApp expLeft expOp _ expRight -> do OpApp expLeft expOp _ expRight -> do
expDocLeft <- docSharedWrapper layoutExpr expLeft expDocLeft <- docSharedWrapper layoutExpr expLeft
expDocOp <- docSharedWrapper layoutExpr expOp expDocOp <- docSharedWrapper layoutExpr expOp
@ -285,47 +277,47 @@ layoutExpr lexpr@(L _ expr) = do
| occNameString occname == "$" -> True | occNameString occname == "$" -> True
(_, L _ (HsApp _ (L _ HsVar{}))) -> False (_, L _ (HsApp _ (L _ HsVar{}))) -> False
_ -> True _ -> True
docAltFilter runFilteredAlternative $ do
$ [ -- one-line -- one-line
(,) True addAlternative
$ docSeq $ docSeq
[ appSep $ docForceSingleline expDocLeft [ appSep $ docForceSingleline expDocLeft
, appSep $ docForceSingleline expDocOp , appSep $ docForceSingleline expDocOp
, docForceSingleline expDocRight , docForceSingleline expDocRight
] ]
-- , -- line + freely indented block for right expression -- -- line + freely indented block for right expression
-- docSeq -- addAlternative
-- [ appSep $ docForceSingleline expDocLeft -- $ docSeq
-- , appSep $ docForceSingleline expDocOp -- [ appSep $ docForceSingleline expDocLeft
-- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight -- , appSep $ docForceSingleline expDocOp
-- ] -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight
, -- two-line -- ]
(,) True -- two-line
$ docAddBaseY BrIndentRegular addAlternative
$ docPar $ docAddBaseY BrIndentRegular
expDocLeft $ docPar
( docForceSingleline expDocLeft
$ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] ( docForceSingleline
) $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]
, -- one-line + par )
(,) allowPar -- one-line + par
$ docSeq addAlternativeCond allowPar
[ appSep $ docForceSingleline expDocLeft $ docSeq
, appSep $ docForceSingleline expDocOp [ appSep $ docForceSingleline expDocLeft
, docForceParSpacing expDocRight , appSep $ docForceSingleline expDocOp
] , docForceParSpacing expDocRight
, -- more lines ]
(,) True -- more lines
$ docAddBaseY BrIndentRegular addAlternative
$ docPar $ docAddBaseY BrIndentRegular
expDocLeft $ docPar
(docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) expDocLeft
] (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight])
NegApp op _ -> do NegApp op _ -> do
opDoc <- docSharedWrapper layoutExpr op opDoc <- docSharedWrapper layoutExpr op
docSeq $ [ docLit $ Text.pack "-" docSeq [ docLit $ Text.pack "-"
, opDoc , opDoc
] ]
HsPar innerExp -> do HsPar innerExp -> do
innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp
docAlt docAlt
@ -364,7 +356,7 @@ layoutExpr lexpr@(L _ expr) = do
case splitFirstLast argDocs of case splitFirstLast argDocs of
FirstLastEmpty -> docSeq FirstLastEmpty -> docSeq
[ openLit [ openLit
, docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit , docNodeAnnKW lexpr (Just AnnOpenP) closeLit
] ]
FirstLastSingleton e -> docAlt FirstLastSingleton e -> docAlt
[ docCols ColTuple [ docCols ColTuple
@ -380,24 +372,21 @@ layoutExpr lexpr@(L _ expr) = do
, closeLit , closeLit
] ]
] ]
FirstLast e1 ems eN -> FirstLast e1 ems eN -> runFilteredAlternative $ do
docAltFilter addAlternativeCond (not hasComments)
[ (,) (not hasComments) $ docCols ColTuple
$ docCols ColTuple $ [docSeq [openLit, docForceSingleline e1]]
( [docSeq [openLit, docForceSingleline e1]] ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e])
++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]]
++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] addAlternative $
) let
, (,) True start = docCols ColTuples
$ let [appSep openLit, e1]
start = docCols ColTuples linesM = ems <&> \d ->
[appSep $ openLit, e1] docCols ColTuples [docCommaSep, d]
linesM = ems <&> \d -> lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN]
docCols ColTuples [docCommaSep, d] end = closeLit
lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end]
end = closeLit
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
]
HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do
cExpDoc <- docSharedWrapper layoutExpr cExp cExpDoc <- docSharedWrapper layoutExpr cExp
binderDoc <- docLit $ Text.pack "->" binderDoc <- docLit $ Text.pack "->"
@ -432,10 +421,10 @@ layoutExpr lexpr@(L _ expr) = do
_ -> BrIndentSpecial 3 _ -> BrIndentSpecial 3
-- TODO: some of the alternatives (especially last and last-but-one) -- TODO: some of the alternatives (especially last and last-but-one)
-- overlap. -- overlap.
docAltFilter runFilteredAlternative $ do
[ -- if _ then _ else _ -- if _ then _ else _
(,) (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
[ appSep $ docLit $ Text.pack "if" [ appSep $ docLit $ Text.pack "if"
, appSep $ docForceSingleline ifExprDoc , appSep $ docForceSingleline ifExprDoc
, appSep $ docLit $ Text.pack "then" , appSep $ docLit $ Text.pack "then"
@ -443,106 +432,105 @@ layoutExpr lexpr@(L _ expr) = do
, appSep $ docLit $ Text.pack "else" , appSep $ docLit $ Text.pack "else"
, docForceSingleline elseExprDoc , docForceSingleline elseExprDoc
] ]
, -- either -- either
-- if expr -- if expr
-- then foo -- then foo
-- bar -- bar
-- else foo -- else foo
-- bar -- bar
-- or -- or
-- if expr -- if expr
-- then -- then
-- stuff -- stuff
-- else -- else
-- stuff -- stuff
-- note that this has par-spacing -- note that this has par-spacing
(,) True addAlternative
$ docSetParSpacing $ docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar
( docSeq ( docSeq
[ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"
, docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc
]) ])
(docLines (docLines
[ docAddBaseY BrIndentRegular [ docAddBaseY BrIndentRegular
$ docNodeAnnKW lexpr (Just AnnThen) $ docNodeAnnKW lexpr (Just AnnThen)
$ docAlt $ docAlt
[ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "then") thenExprDoc
]
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "then") thenExprDoc $ docAlt
] [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docAlt $ docPar (docLit $ Text.pack "else") elseExprDoc
[ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] ]
])
-- either
-- if multi
-- line
-- condition
-- then foo
-- bar
-- else foo
-- bar
-- or
-- if multi
-- line
-- condition
-- then
-- stuff
-- else
-- stuff
-- note that this does _not_ have par-spacing
addAlternative
$ docAddBaseY BrIndentRegular
$ docPar
( docAddBaseY maySpecialIndent
$ docSeq
[ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"
, docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc
])
(docLines
[ docAddBaseY BrIndentRegular
$ docNodeAnnKW lexpr (Just AnnThen)
$ docAlt
[ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "then") thenExprDoc
]
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "else") elseExprDoc $ docAlt
] [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]
]) , docAddBaseY BrIndentRegular
, -- either $ docPar (docLit $ Text.pack "else") elseExprDoc
-- if multi ]
-- line ])
-- condition addAlternative
-- then foo $ docSetBaseY
-- bar $ docLines
-- else foo [ docAddBaseY maySpecialIndent
-- bar
-- or
-- if multi
-- line
-- condition
-- then
-- stuff
-- else
-- stuff
-- note that this does _not_ have par-spacing
(,) True
$ docAddBaseY BrIndentRegular
$ docPar
( docAddBaseY maySpecialIndent
$ docSeq $ docSeq
[ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"
, docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc
]) ]
(docLines , docNodeAnnKW lexpr (Just AnnThen)
[ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docNodeAnnKW lexpr (Just AnnThen) $ docPar (docLit $ Text.pack "then") thenExprDoc
$ docAlt , docAddBaseY BrIndentRegular
[ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] $ docPar (docLit $ Text.pack "else") elseExprDoc
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "then") thenExprDoc
]
, docAddBaseY BrIndentRegular
$ docAlt
[ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "else") elseExprDoc
]
])
, (,) True
$ docSetBaseY
$ docLines
[ docAddBaseY maySpecialIndent
$ docSeq
[ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"
, docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc
] ]
, docNodeAnnKW lexpr (Just AnnThen)
$ docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "then") thenExprDoc
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "else") elseExprDoc
]
]
HsMultiIf _ cases -> do HsMultiIf _ cases -> do
clauseDocs <- cases `forM` layoutGrhs clauseDocs <- cases `forM` layoutGrhs
binderDoc <- docLit $ Text.pack "->" binderDoc <- docLit $ Text.pack "->"
hasComments <- hasAnyCommentsBelow lexpr hasComments <- hasAnyCommentsBelow lexpr
docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "if") (docLit $ Text.pack "if")
(layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments)
HsLet binds exp1 -> do HsLet binds exp1 -> do
expDoc1 <- docSharedWrapper layoutExpr exp1 expDoc1 <- docSharedWrapper layoutExpr exp1
-- We jump through some ugly hoops here to ensure proper sharing. -- We jump through some ugly hoops here to ensure proper sharing.
mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return)
=<< layoutLocalBinds binds =<< layoutLocalBinds binds
@ -562,9 +550,9 @@ layoutExpr lexpr@(L _ expr) = do
Just [bindDoc] -> docAlt Just [bindDoc] -> docAlt
[ docSeq [ docSeq
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, appSep $ docForceSingleline $ bindDoc , appSep $ docForceSingleline bindDoc
, appSep $ docLit $ Text.pack "in" , appSep $ docLit $ Text.pack "in"
, docForceSingleline $ expDoc1 , docForceSingleline expDoc1
] ]
, docLines , docLines
[ docAlt [ docAlt
@ -576,7 +564,7 @@ layoutExpr lexpr@(L _ expr) = do
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar $ docPar
(docLit $ Text.pack "let") (docLit $ Text.pack "let")
(docSetBaseAndIndent $ bindDoc) (docSetBaseAndIndent bindDoc)
] ]
, docAlt , docAlt
[ docSeq [ docSeq
@ -586,11 +574,11 @@ layoutExpr lexpr@(L _ expr) = do
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar $ docPar
(docLit $ Text.pack "in") (docLit $ Text.pack "in")
(docSetBaseY $ expDoc1) (docSetBaseY expDoc1)
] ]
] ]
] ]
Just bindDocs@(_:_) -> docAltFilter Just bindDocs@(_:_) -> runFilteredAlternative $ do
--either --either
-- let -- let
-- a = b -- a = b
@ -604,43 +592,39 @@ layoutExpr lexpr@(L _ expr) = do
-- c = d -- c = d
-- in -- in
-- fooooooooooooooooooo -- fooooooooooooooooooo
[ ( indentPolicy == IndentPolicyLeft addAlternativeCond (indentPolicy == IndentPolicyLeft)
, docLines $ docLines
[ docAddBaseY BrIndentRegular [ docAddBaseY BrIndentRegular
$ docPar $ docPar
(docLit $ Text.pack "let") (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ bindDocs) (docSetBaseAndIndent $ docLines bindDocs)
, docSeq , docSeq
[ docLit $ Text.pack "in " [ docLit $ Text.pack "in "
, docAddBaseY BrIndentRegular $ expDoc1 , docAddBaseY BrIndentRegular expDoc1
]
] ]
) ]
, ( indentPolicy /= IndentPolicyLeft addAlternativeCond (indentPolicy /= IndentPolicyLeft)
, docLines $ docLines
[ docSeq [ docSeq
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, docSetBaseAndIndent $ docLines $ bindDocs , docSetBaseAndIndent $ docLines bindDocs
]
, docSeq
[ appSep $ docLit $ Text.pack "in "
, docSetBaseY $ expDoc1
]
] ]
) , docSeq
, ( True [ appSep $ docLit $ Text.pack "in "
, docLines , docSetBaseY expDoc1
[ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ bindDocs)
, docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "in")
(docSetBaseY $ expDoc1)
] ]
) ]
] addAlternative
$ docLines
[ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ bindDocs)
, docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "in")
(docSetBaseY $ expDoc1)
]
_ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]
-- docSeq [appSep $ docLit "let in", expDoc1] -- docSeq [appSep $ docLit "let in", expDoc1]
HsDo DoExpr (L _ stmts) _ -> do HsDo DoExpr (L _ stmts) _ -> do
@ -660,11 +644,11 @@ layoutExpr lexpr@(L _ expr) = do
HsDo x (L _ stmts) _ | case x of { ListComp -> True HsDo x (L _ stmts) _ | case x of { ListComp -> True
; MonadComp -> True ; MonadComp -> True
; _ -> False } -> do ; _ -> False } -> do
stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
hasComments <- hasAnyCommentsBelow lexpr hasComments <- hasAnyCommentsBelow lexpr
docAltFilter runFilteredAlternative $ do
[ (,) (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
[ docNodeAnnKW lexpr Nothing [ docNodeAnnKW lexpr Nothing
$ appSep $ appSep
$ docLit $ docLit
@ -675,11 +659,11 @@ layoutExpr lexpr@(L _ expr) = do
$ List.last stmtDocs $ List.last stmtDocs
, appSep $ docLit $ Text.pack "|" , appSep $ docLit $ Text.pack "|"
, docSeq $ List.intersperse docCommaSep , docSeq $ List.intersperse docCommaSep
$ fmap docForceSingleline $ List.init stmtDocs $ docForceSingleline <$> List.init stmtDocs
, docLit $ Text.pack " ]" , docLit $ Text.pack " ]"
] ]
, (,) True addAlternative $
$ let let
start = docCols ColListComp start = docCols ColListComp
[ docNodeAnnKW lexpr Nothing [ docNodeAnnKW lexpr Nothing
$ appSep $ docLit $ Text.pack "[" $ appSep $ docLit $ Text.pack "["
@ -694,12 +678,11 @@ layoutExpr lexpr@(L _ expr) = do
docCols ColListComp [docCommaSep, d] docCols ColListComp [docCommaSep, d]
end = docLit $ Text.pack "]" end = docLit $ Text.pack "]"
in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]
]
HsDo{} -> do HsDo{} -> do
-- TODO -- TODO
unknownNodeError "HsDo{} no comp" lexpr unknownNodeError "HsDo{} no comp" lexpr
ExplicitList _ _ elems@(_:_) -> do ExplicitList _ _ elems@(_:_) -> do
elemDocs <- elems `forM` docSharedWrapper layoutExpr elemDocs <- elems `forM` docSharedWrapper layoutExpr
hasComments <- hasAnyCommentsBelow lexpr hasComments <- hasAnyCommentsBelow lexpr
case splitFirstLast elemDocs of case splitFirstLast elemDocs of
FirstLastEmpty -> docSeq FirstLastEmpty -> docSeq
@ -716,28 +699,26 @@ layoutExpr lexpr@(L _ expr) = do
[ docSeq [ docSeq
[ docLit $ Text.pack "[" [ docLit $ Text.pack "["
, docSeparator , docSeparator
, docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e
] ]
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
] ]
FirstLast e1 ems eN -> FirstLast e1 ems eN -> runFilteredAlternative $ do
docAltFilter addAlternativeCond (not hasComments)
[ (,) (not hasComments)
$ docSeq $ docSeq
$ [docLit $ Text.pack "["] $ [docLit $ Text.pack "["]
++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]))
++ [docLit $ Text.pack "]"] ++ [docLit $ Text.pack "]"]
, (,) True addAlternative $
$ let let
start = docCols ColList start = docCols ColList
[appSep $ docLit $ Text.pack "[", e1] [appSep $ docLit $ Text.pack "[", e1]
linesM = ems <&> \d -> linesM = ems <&> \d ->
docCols ColList [docCommaSep, d] docCols ColList [docCommaSep, d]
lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]
end = docLit $ Text.pack "]" end = docLit $ Text.pack "]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
]
ExplicitList _ _ [] -> ExplicitList _ _ [] ->
docLit $ Text.pack "[]" docLit $ Text.pack "[]"
ExplicitPArr{} -> do ExplicitPArr{} -> do
@ -757,20 +738,20 @@ layoutExpr lexpr@(L _ expr) = do
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
else Just <$> docSharedWrapper layoutExpr fExpr else Just <$> docSharedWrapper layoutExpr fExpr
return $ (fieldl, lrdrNameToText lnameF, fExpDoc) return (fieldl, lrdrNameToText lnameF, fExpDoc)
let line1 appender wrapper = let line1 appender wrapper =
[ appender $ docLit $ Text.pack "{" [ appender $ docLit $ Text.pack "{"
, docWrapNodePrior fd1l $ appSep $ docLit $ fd1n , docWrapNodePrior fd1l $ appSep $ docLit fd1n
, case fd1e of , case fd1e of
Just x -> docSeq Just x -> docSeq
[ appSep $ docLit $ Text.pack "=" [ appSep $ docLit $ Text.pack "="
, docWrapNodeRest fd1l $ wrapper $ x , docWrapNodeRest fd1l $ wrapper x
] ]
Nothing -> docEmpty Nothing -> docEmpty
] ]
let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> let lineR wrapper = fdr <&> \(lfield, fText, fDoc) ->
[ docCommaSep [ docCommaSep
, appSep $ docLit $ fText , appSep $ docLit fText
, case fDoc of , case fDoc of
Just x -> docWrapNode lfield $ docSeq Just x -> docWrapNode lfield $ docSeq
[ appSep $ docLit $ Text.pack "=" [ appSep $ docLit $ Text.pack "="
@ -784,14 +765,14 @@ layoutExpr lexpr@(L _ expr) = do
] ]
docAlt docAlt
[ docSeq [ docSeq
$ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator]
++ line1 id docForceSingleline ++ line1 id docForceSingleline
++ join (lineR docForceSingleline) ++ join (lineR docForceSingleline)
++ lineN ++ lineN
, docSetParSpacing , docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar
(docNodeAnnKW lexpr Nothing $ nameDoc) (docNodeAnnKW lexpr Nothing nameDoc)
( docNonBottomSpacing ( docNonBottomSpacing
$ docLines $ docLines
$ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)]
@ -808,20 +789,20 @@ layoutExpr lexpr@(L _ expr) = do
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
else Just <$> docSharedWrapper layoutExpr fExpr else Just <$> docSharedWrapper layoutExpr fExpr
return $ (fieldl, lrdrNameToText lnameF, fExpDoc) return (fieldl, lrdrNameToText lnameF, fExpDoc)
let line1 appender wrapper = let line1 appender wrapper =
[ appender $ docLit $ Text.pack "{" [ appender $ docLit $ Text.pack "{"
, docWrapNodePrior fd1l $ appSep $ docLit $ fd1n , docWrapNodePrior fd1l $ appSep $ docLit fd1n
, case fd1e of , case fd1e of
Just x -> docSeq Just x -> docSeq
[ appSep $ docLit $ Text.pack "=" [ appSep $ docLit $ Text.pack "="
, docWrapNodeRest fd1l $ wrapper $ x , docWrapNodeRest fd1l $ wrapper x
] ]
Nothing -> docEmpty Nothing -> docEmpty
] ]
let lineR wrapper = fdr <&> \(lfield, fText, fDoc) -> let lineR wrapper = fdr <&> \(lfield, fText, fDoc) ->
[ docCommaSep [ docCommaSep
, appSep $ docLit $ fText , appSep $ docLit fText
, case fDoc of , case fDoc of
Just x -> docWrapNode lfield $ docSeq Just x -> docWrapNode lfield $ docSeq
[ appSep $ docLit $ Text.pack "=" [ appSep $ docLit $ Text.pack "="
@ -839,7 +820,7 @@ layoutExpr lexpr@(L _ expr) = do
] ]
docAlt docAlt
[ docSeq [ docSeq
$ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator] $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator]
++ line1 id docForceSingleline ++ line1 id docForceSingleline
++ join (lineR docForceSingleline) ++ join (lineR docForceSingleline)
++ lineDot ++ lineDot
@ -847,7 +828,7 @@ layoutExpr lexpr@(L _ expr) = do
, docSetParSpacing , docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar
(docNodeAnnKW lexpr Nothing $ nameDoc) (docNodeAnnKW lexpr Nothing nameDoc)
( docNonBottomSpacing ( docNonBottomSpacing
$ docLines $ docLines
$ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)] $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)]
@ -870,77 +851,75 @@ layoutExpr lexpr@(L _ expr) = do
return $ case ambName of return $ case ambName of
Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
docAltFilter runFilteredAlternative $ do
-- container { fieldA = blub, fieldB = blub } -- container { fieldA = blub, fieldB = blub }
[ ( True addAlternative
, docSeq $ docSeq
[ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, appSep $ docSeq $ List.intersperse docCommaSep , appSep $ docSeq $ List.intersperse docCommaSep
$ rFs <&> \case $ rFs <&> \case
(lfield, fieldStr, Just fieldDoc) -> (lfield, fieldStr, Just fieldDoc) ->
docWrapNode lfield $ docSeq docWrapNode lfield $ docSeq
[ appSep $ docLit fieldStr [ appSep $ docLit fieldStr
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
, docForceSingleline fieldDoc , docForceSingleline fieldDoc
] ]
(lfield, fieldStr, Nothing) -> (lfield, fieldStr, Nothing) ->
docWrapNode lfield $ docLit fieldStr docWrapNode lfield $ docLit fieldStr
, docLit $ Text.pack "}" , docLit $ Text.pack "}"
] ]
)
-- hanging single-line fields -- hanging single-line fields
-- container { fieldA = blub -- container { fieldA = blub
-- , fieldB = blub -- , fieldB = blub
-- } -- }
, ( indentPolicy /= IndentPolicyLeft addAlternativeCond (indentPolicy /= IndentPolicyLeft)
, docSeq $ docSeq
[ docNodeAnnKW lexpr Nothing $ appSep rExprDoc [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc
, docSetBaseY $ docLines $ let , docSetBaseY $ docLines $ let
line1 = docCols ColRecUpdate line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{" [ appSep $ docLit $ Text.pack "{"
, docWrapNodePrior rF1f $ appSep $ docLit $ rF1n , docWrapNodePrior rF1f $ appSep $ docLit rF1n
, case rF1e of , case rF1e of
Just x -> docWrapNodeRest rF1f $ docSeq Just x -> docWrapNodeRest rF1f $ docSeq
[ appSep $ docLit $ Text.pack "=" [ appSep $ docLit $ Text.pack "="
, docForceSingleline x
]
Nothing -> docEmpty
]
lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate
[ docCommaSep
, appSep $ docLit fText
, case fDoc of
Just x -> docSeq [ appSep $ docLit $ Text.pack "="
, docForceSingleline x , docForceSingleline x
] ]
Nothing -> docEmpty Nothing -> docEmpty
] ]
lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate lineN = docSeq
[ docCommaSep [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
, appSep $ docLit $ fText , docLit $ Text.pack "}"
, case fDoc of ]
Just x -> docSeq [ appSep $ docLit $ Text.pack "=" in [line1] ++ lineR ++ [lineN]
, docForceSingleline x ]
] -- non-hanging with expressions placed to the right of the names
Nothing -> docEmpty -- container
] -- { fieldA = blub
lineN = docSeq -- , fieldB = potentially
[ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty -- multiline
, docLit $ Text.pack "}" -- }
] addAlternative
in [line1] ++ lineR ++ [lineN] $ docSetParSpacing
]
)
-- non-hanging with expressions placed to the right of the names
-- container
-- { fieldA = blub
-- , fieldB = potentially
-- multiline
-- }
, ( True
, docSetParSpacing
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar
(docNodeAnnKW lexpr Nothing $ rExprDoc) (docNodeAnnKW lexpr Nothing rExprDoc)
(docNonBottomSpacing $ docLines $ let (docNonBottomSpacing $ docLines $ let
expressionWrapper = if indentPolicy == IndentPolicyLeft expressionWrapper = if indentPolicy == IndentPolicyLeft
then docForceParSpacing then docForceParSpacing
else docSetBaseY else docSetBaseY
line1 = docCols ColRecUpdate line1 = docCols ColRecUpdate
[ appSep $ docLit $ Text.pack "{" [ appSep $ docLit $ Text.pack "{"
, docWrapNodePrior rF1f $ appSep $ docLit $ rF1n , docWrapNodePrior rF1f $ appSep $ docLit rF1n
, docWrapNodeRest rF1f $ case rF1e of , docWrapNodeRest rF1f $ case rF1e of
Just x -> docAlt Just x -> docAlt
[ docSeq [ appSep $ docLit $ Text.pack "=" [ docSeq [ appSep $ docLit $ Text.pack "="
@ -954,7 +933,7 @@ layoutExpr lexpr@(L _ expr) = do
lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield
$ docCols ColRecUpdate $ docCols ColRecUpdate
[ docCommaSep [ docCommaSep
, appSep $ docLit $ fText , appSep $ docLit fText
, case fDoc of , case fDoc of
Just x -> docAlt Just x -> docAlt
[ docSeq [ appSep $ docLit $ Text.pack "=" [ docSeq [ appSep $ docLit $ Text.pack "="
@ -971,8 +950,6 @@ layoutExpr lexpr@(L _ expr) = do
] ]
in [line1] ++ lineR ++ [lineN] in [line1] ++ lineR ++ [lineN]
) )
)
]
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do
#else /* ghc-8.0 */ #else /* ghc-8.0 */
@ -1078,7 +1055,7 @@ layoutExpr lexpr@(L _ expr) = do
docLit $ Text.pack "_" docLit $ Text.pack "_"
EAsPat asName asExpr -> do EAsPat asName asExpr -> do
docSeq docSeq
[ docLit $ (lrdrNameToText asName) <> Text.pack "@" [ docLit $ lrdrNameToText asName <> Text.pack "@"
, layoutExpr asExpr , layoutExpr asExpr
] ]
EViewPat{} -> do EViewPat{} -> do
@ -1112,10 +1089,10 @@ litBriDoc = \case
HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsRat (FL t _) _type -> BDFLit $ Text.pack t HsRat (FL t _) _type -> BDFLit $ Text.pack t
HsFloatPrim (FL t _) -> BDFLit $ Text.pack t HsFloatPrim (FL t _) -> BDFLit $ Text.pack t
HsDoublePrim (FL t _) -> BDFLit $ Text.pack t HsDoublePrim (FL t _) -> BDFLit $ Text.pack t
_ -> error "litBriDoc: literal with no SourceText" _ -> error "litBriDoc: literal with no SourceText"
overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt

52
src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -46,18 +46,15 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"]
IEThingWith _ _ ns _ -> do IEThingWith _ _ ns _ -> do
hasComments <- hasAnyCommentsBelow lie hasComments <- hasAnyCommentsBelow lie
docAltFilter runFilteredAlternative $ do
[ ( not hasComments addAlternativeCond (not hasComments)
, docSeq $ docSeq
$ [ien, docLit $ Text.pack "("] $ [ien, docLit $ Text.pack "("]
++ intersperse docCommaSep (map nameDoc ns) ++ intersperse docCommaSep (map nameDoc ns)
++ [docParenR] ++ [docParenR]
) addAlternative
, (otherwise $ docAddBaseY BrIndentRegular
, docAddBaseY BrIndentRegular
$ docPar ien (layoutItems (splitFirstLast ns)) $ docPar ien (layoutItems (splitFirstLast ns))
)
]
where where
nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
@ -121,25 +118,22 @@ layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline llies = do layoutLLIEs enableSingleline llies = do
ieDs <- layoutAnnAndSepLLIEs llies ieDs <- layoutAnnAndSepLLIEs llies
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
case ieDs of runFilteredAlternative $
[] -> docAltFilter case ieDs of
[ (not hasComments, docLit $ Text.pack "()") [] -> do
, ( hasComments addAlternativeCond (not hasComments) $
, docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) docLit $ Text.pack "()"
addAlternativeCond hasComments $
docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])
docParenR docParenR
) (ieDsH:ieDsT) -> do
] addAlternativeCond (not hasComments && enableSingleline)
(ieDsH:ieDsT) -> docAltFilter $ docSeq
[ ( not hasComments && enableSingleline $ [docLit (Text.pack "(")]
, docSeq ++ (docForceSingleline <$> ieDs)
$ [docLit (Text.pack "(")] ++ [docParenR]
++ (docForceSingleline <$> ieDs) addAlternative
++ [docParenR] $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
) $ docLines
, ( otherwise $ ieDsT
, docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) ++ [docParenR]
$ docLines
$ ieDsT
++ [docParenR]
)
]

30
src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
View File

@ -98,25 +98,21 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of
[] -> if hasComments [] -> if hasComments
then docPar then docPar
(docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty])
(docEnsureIndent (BrIndentSpecial hidDocColDiff) $ docParenR) (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] else docSeq [hidDoc, docParenLSep, docSeparator, docParenR]
-- ..[hiding].( b ) -- ..[hiding].( b )
[ieD] -> docAltFilter [ieD] -> runFilteredAlternative $ do
[ ( not hasComments addAlternativeCond (not hasComments)
, docSeq $ docSeq
[ hidDoc [ hidDoc
, docParenLSep , docParenLSep
, docForceSingleline $ ieD , docForceSingleline ieD
, docSeparator , docSeparator
, docParenR , docParenR
] ]
) addAlternative $ docPar
, ( otherwise (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
, docPar (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
)
]
-- ..[hiding].( b -- ..[hiding].( b
-- , b' -- , b'
-- ) -- )

42
src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -38,25 +38,27 @@ layoutModule lmod@(L _ mod') = case mod' of
[ docNodeAnnKW lmod Nothing docEmpty [ docNodeAnnKW lmod Nothing docEmpty
-- A pseudo node that serves merely to force documentation -- A pseudo node that serves merely to force documentation
-- before the node -- before the node
, docNodeMoveToKWDP lmod AnnModule $ docAltFilter , docNodeMoveToKWDP lmod AnnModule $ runFilteredAlternative $ do
[ (,) allowSingleLineExportList $ docForceSingleline $ docSeq addAlternativeCond allowSingleLineExportList $
[ appSep $ docLit $ Text.pack "module" docForceSingleline
, appSep $ docLit tn $ docSeq
, docWrapNode lmod $ appSep $ case les of [ appSep $ docLit $ Text.pack "module"
Nothing -> docEmpty , appSep $ docLit tn
Just x -> layoutLLIEs True x , docWrapNode lmod $ appSep $ case les of
, docLit $ Text.pack "where" Nothing -> docEmpty
] Just x -> layoutLLIEs True x
, (,) otherwise $ docLines , docLit $ Text.pack "where"
[ docAddBaseY BrIndentRegular $ docPar ]
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn] addAlternative
) $ docLines
(docWrapNode lmod $ case les of [ docAddBaseY BrIndentRegular $ docPar
Nothing -> docEmpty (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]
Just x -> layoutLLIEs False x )
) (docWrapNode lmod $ case les of
, docLit $ Text.pack "where" Nothing -> docEmpty
] Just x -> layoutLLIEs False x
] )
, docLit $ Text.pack "where"
]
] ]
: map layoutImport imports : map layoutImport imports

22
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -94,14 +94,14 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
else Just <$> docSharedWrapper layoutPat fPat else Just <$> docSharedWrapper layoutPat fPat
return $ (lrdrNameToText lnameF, fExpDoc) return (lrdrNameToText lnameF, fExpDoc)
fmap Seq.singleton $ docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, docSeq $ List.intersperse docCommaSep , docSeq $ List.intersperse docCommaSep
$ fds <&> \case $ fds <&> \case
(fieldName, Just fieldDoc) -> docSeq (fieldName, Just fieldDoc) -> docSeq
[ appSep $ docLit $ fieldName [ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
, fieldDoc >>= colsWrapPat , fieldDoc >>= colsWrapPat
] ]
@ -112,7 +112,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do
-- Abc { .. } -> expr -- Abc { .. } -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
fmap Seq.singleton $ docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, docLit $ Text.pack "{..}" , docLit $ Text.pack "{..}"
] ]
@ -123,13 +123,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
else Just <$> docSharedWrapper layoutPat fPat else Just <$> docSharedWrapper layoutPat fPat
return $ (lrdrNameToText lnameF, fExpDoc) return (lrdrNameToText lnameF, fExpDoc)
fmap Seq.singleton $ docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, docSeq $ fds >>= \case , docSeq $ fds >>= \case
(fieldName, Just fieldDoc) -> (fieldName, Just fieldDoc) ->
[ appSep $ docLit $ fieldName [ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
, fieldDoc >>= colsWrapPat , fieldDoc >>= colsWrapPat
, docCommaSep , docCommaSep
@ -167,7 +167,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
docAddBaseY BrIndentRegular $ docSeq docAddBaseY BrIndentRegular $ docSeq
[ appSep $ return xN [ appSep $ return xN
, appSep $ docLit $ Text.pack "::" , appSep $ docLit $ Text.pack "::"
, docForceSingleline $ tyDoc , docForceSingleline tyDoc
] ]
return $ xR Seq.|> xN' return $ xR Seq.|> xN'
ListPat elems _ _ -> ListPat elems _ _ ->
@ -193,7 +193,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- else -- else
-- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n -- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n
-- endif -- endif
_ -> fmap return $ briDocByExactInlineOnly "some unknown pattern" lpat _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
@ -205,7 +205,7 @@ wrapPatPrepend
wrapPatPrepend pat prepElem = do wrapPatPrepend pat prepElem = do
patDocs <- layoutPat pat patDocs <- layoutPat pat
case Seq.viewl patDocs of case Seq.viewl patDocs of
Seq.EmptyL -> return $ Seq.empty Seq.EmptyL -> return Seq.empty
x1 Seq.:< xR -> do x1 Seq.:< xR -> do
x1' <- docSeq [prepElem, return x1] x1' <- docSeq [prepElem, return x1]
return $ x1' Seq.<| xR return $ x1' Seq.<| xR
@ -216,7 +216,7 @@ wrapPatListy
-> String -> String
-> ToBriDocM (Seq BriDocNumbered) -> ToBriDocM (Seq BriDocNumbered)
wrapPatListy elems start end = do wrapPatListy elems start end = do
elemDocs <- Seq.fromList elems `forM` \e -> layoutPat e >>= colsWrapPat elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat)
sDoc <- docLit $ Text.pack start sDoc <- docLit $ Text.pack start
eDoc <- docLit $ Text.pack end eDoc <- docLit $ Text.pack end
case Seq.viewl elemDocs of case Seq.viewl elemDocs of

68
src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
View File

@ -71,46 +71,40 @@ layoutStmt lstmt@(L _ stmt) = do
(docLit $ Text.pack "let") (docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc) (docSetBaseAndIndent $ return bindDoc)
] ]
Just bindDocs -> docAltFilter Just bindDocs -> runFilteredAlternative $ do
[ -- let aaa = expra -- let aaa = expra
-- bbb = exprb -- bbb = exprb
-- ccc = exprc -- ccc = exprc
( indentPolicy /= IndentPolicyLeft addAlternativeCond (indentPolicy /= IndentPolicyLeft)
, docSeq $ docSeq
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, docSetBaseAndIndent $ docLines $ return <$> bindDocs , docSetBaseAndIndent $ docLines $ return <$> bindDocs
] ]
) -- let
, -- let -- aaa = expra
-- aaa = expra -- bbb = exprb
-- bbb = exprb -- ccc = exprc
-- ccc = exprc addAlternative $
( True docAddBaseY BrIndentRegular $ docPar
, docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "let") (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs) (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
) RecStmt stmts _ _ _ _ _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1
-- stmt2
-- stmt3
addAlternativeCond (indentPolicy /= IndentPolicyLeft)
$ docSeq
[ docLit (Text.pack "rec")
, docSeparator
, docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
] ]
RecStmt stmts _ _ _ _ _ _ _ _ _ -> docAltFilter -- rec
[ -- rec stmt1 -- stmt1
-- stmt2 -- stmt2
-- stmt3 -- stmt3
( indentPolicy /= IndentPolicyLeft addAlternative
, docSeq $ docAddBaseY BrIndentRegular
[ docLit (Text.pack "rec") $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts)
, docSeparator
, docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
]
)
, -- rec
-- stmt1
-- stmt2
-- stmt3
( True
, docAddBaseY BrIndentRegular
$ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts)
)
]
BodyStmt expr _ _ _ -> do BodyStmt expr _ _ _ -> do
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docAddBaseY BrIndentRegular $ expDoc docAddBaseY BrIndentRegular $ expDoc

6
src/Language/Haskell/Brittany/Internal/Prelude.hs
View File

@ -255,14 +255,16 @@ import Debug.Trace as E ( trace
import Foreign.ForeignPtr as E ( ForeignPtr import Foreign.ForeignPtr as E ( ForeignPtr
) )
import Data.Monoid as E ( (<>) import Data.Monoid as E ( mconcat
, mconcat
, Monoid (..) , Monoid (..)
) )
import Data.Bifunctor as E ( bimap ) import Data.Bifunctor as E ( bimap )
import Data.Functor as E ( (<$), ($>) ) import Data.Functor as E ( (<$), ($>) )
import Data.Function as E ( (&) ) import Data.Function as E ( (&) )
import Data.Semigroup as E ( (<>)
, Semigroup(..)
)
import System.IO as E ( hFlush import System.IO as E ( hFlush
, stdout , stdout
) )

5
src/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -84,9 +84,12 @@ fromOptionIdentity x y =
newtype Max a = Max { getMax :: a } newtype Max a = Max { getMax :: a }
deriving (Eq, Ord, Show, Bounded, Num) deriving (Eq, Ord, Show, Bounded, Num)
instance (Num a, Ord a) => Semigroup (Max a) where
(<>) = Data.Coerce.coerce (max :: a -> a -> a)
instance (Num a, Ord a) => Monoid (Max a) where instance (Num a, Ord a) => Monoid (Max a) where
mempty = Max 0 mempty = Max 0
mappend = Data.Coerce.coerce (max :: a -> a -> a) mappend = (<>)
newtype ShowIsId = ShowIsId String deriving Data newtype ShowIsId = ShowIsId String deriving Data

2
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-11.0 resolver: lts-11.1
packages: packages:
- . - .