diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs
index f46230b..ffe3dd7 100644
--- a/src-unittests/TestUtils.hs
+++ b/src-unittests/TestUtils.hs
@@ -52,7 +52,9 @@ defaultTestConfig = Config
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
}
- , _conf_errorHandling = _conf_errorHandling staticDefaultConfig
+ , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
+ { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever
+ }
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
diff --git a/src/Language/Haskell/Brittany/Config.hs b/src/Language/Haskell/Brittany/Config.hs
index b281d9c..e91f698 100644
--- a/src/Language/Haskell/Brittany/Config.hs
+++ b/src/Language/Haskell/Brittany/Config.hs
@@ -93,6 +93,7 @@ configParser = do
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError
, _econf_CPPMode = mempty
+ , _econf_ExactPrintFallback = mempty
}
, _conf_forward = ForwardOptions
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]
diff --git a/src/Language/Haskell/Brittany/Config/Types.hs b/src/Language/Haskell/Brittany/Config/Types.hs
index cfae3eb..15995d8 100644
--- a/src/Language/Haskell/Brittany/Config/Types.hs
+++ b/src/Language/Haskell/Brittany/Config/Types.hs
@@ -64,9 +64,17 @@ data ForwardOptionsF f = ForwardOptions
deriving (Generic)
data ErrorHandlingConfigF f = ErrorHandlingConfig
- { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
- , _econf_Werror :: f (Semigroup.Last Bool)
- , _econf_CPPMode :: f (Semigroup.Last CPPMode)
+ { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
+ , _econf_Werror :: f (Semigroup.Last Bool)
+ , _econf_CPPMode :: f (Semigroup.Last CPPMode)
+ , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode)
+ -- ^ Determines when to fall back on the exactprint'ed output when
+ -- syntactical constructs are encountered which are not yet handled by
+ -- brittany.
+ -- Note that the "risky" setting is risky because even with the check of
+ -- the syntactic validity of the brittany output, at least in theory there
+ -- may be cases where the output is syntactically/semantically valid but
+ -- has different semantics that the code pre-transformation.
}
deriving (Generic)
@@ -182,6 +190,8 @@ makeFromJSON (ColumnAlignMode)
makeToJSON (ColumnAlignMode)
makeFromJSON (CPPMode)
makeToJSON (CPPMode)
+makeFromJSON (ExactPrintFallbackMode)
+makeToJSON (ExactPrintFallbackMode)
makeFromJSONOption (LayoutConfigF)
makeFromJSONMaybe (LayoutConfigF)
@@ -278,6 +288,15 @@ data CPPMode = CPPModeAbort -- abort program on seeing -XCPP
-- file.)
deriving (Show, Generic, Data)
+data ExactPrintFallbackMode
+ = ExactPrintFallbackModeNever -- never fall back on exactprinting
+ | ExactPrintFallbackModeInline -- fall back only if there are no newlines in
+ -- the exactprint'ed output.
+ | ExactPrintFallbackModeRisky -- fall back even in the presence of newlines.
+ -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF
+ -- A PROGRAM BY TRANSFORMING IT.
+ deriving (Show, Generic, Data)
+
staticDefaultConfig :: Config
staticDefaultConfig = Config
{ _conf_debug = DebugConfig
@@ -304,9 +323,10 @@ staticDefaultConfig = Config
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
}
, _conf_errorHandling = ErrorHandlingConfig
- { _econf_produceOutputOnErrors = coerce False
- , _econf_Werror = coerce False
- , _econf_CPPMode = coerce CPPModeAbort
+ { _econf_produceOutputOnErrors = coerce False
+ , _econf_Werror = coerce False
+ , _econf_CPPMode = coerce CPPModeAbort
+ , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline
}
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
@@ -347,11 +367,12 @@ instance CZip LayoutConfigF where
(f x8 y8)
instance CZip ErrorHandlingConfigF where
- cZip f (ErrorHandlingConfig x1 x2 x3)
- (ErrorHandlingConfig y1 y2 y3) = ErrorHandlingConfig
+ cZip f (ErrorHandlingConfig x1 x2 x3 x4)
+ (ErrorHandlingConfig y1 y2 y3 y4) = ErrorHandlingConfig
(f x1 y1)
(f x2 y2)
(f x3 y3)
+ (f x4 y4)
instance CZip ForwardOptionsF where
cZip f (ForwardOptions x1)
diff --git a/src/Language/Haskell/Brittany/LayouterBasics.hs b/src/Language/Haskell/Brittany/LayouterBasics.hs
index d0ea1d1..f681439 100644
--- a/src/Language/Haskell/Brittany/LayouterBasics.hs
+++ b/src/Language/Haskell/Brittany/LayouterBasics.hs
@@ -36,6 +36,7 @@ module Language.Haskell.Brittany.LayouterBasics
, docSetBaseAndIndent
, briDocByExact
, briDocByExactNoComment
+ , briDocByExactInlineOnly
, foldedAnnKeys
, unknownNodeError
, appSep
@@ -118,6 +119,10 @@ briDocByExact ast = do
docExt ast anns True
-- | Use ExactPrint's output for this node.
+-- Consider that for multi-line input, the indentation of the code produced
+-- by ExactPrint might be different, and even incompatible with the indentation
+-- of its surroundings as layouted by brittany. But there are safe uses of
+-- this, e.g. for any top-level declarations.
briDocByExactNoComment
:: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
@@ -129,6 +134,37 @@ briDocByExactNoComment ast = do
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False
+-- | Use ExactPrint's output for this node, presuming that this output does
+-- not contain any newlines. If this property is not met, the semantics
+-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
+briDocByExactInlineOnly
+ :: (ExactPrint.Annotate.Annotate ast, Data ast)
+ => String
+ -> GenLocated SrcSpan ast
+ -> ToBriDocM BriDocNumbered
+briDocByExactInlineOnly infoStr ast = do
+ anns <- mAsk
+ traceIfDumpConf "ast"
+ _dconf_dump_ast_unknown
+ (printTreeWithCustom 100 (customLayouterF anns) ast)
+ let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
+ fallbackMode <-
+ mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
+ let exactPrintNode = allocateNode $ BDFExternal
+ (ExactPrint.Types.mkAnnKey ast)
+ (foldedAnnKeys ast)
+ False
+ exactPrinted
+ let
+ errorAction = do
+ mTell $ [LayoutErrorUnknownNode infoStr ast]
+ docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
+ case (fallbackMode, Text.lines exactPrinted) of
+ (ExactPrintFallbackModeNever, _ ) -> errorAction
+ (_ , [_]) -> exactPrintNode
+ (ExactPrintFallbackModeRisky, _ ) -> exactPrintNode
+ _ -> errorAction
+
rdrNameToText :: RdrName -> Text
-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs
index 643ef67..72c39bc 100644
--- a/src/Language/Haskell/Brittany/Layouters/Expr.hs
+++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs
@@ -38,13 +38,13 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
TrueExprHole oname -> docLit $ Text.pack $ occNameString oname
HsRecFld{} -> do
-- TODO
- unknownNodeError "HsRecFld" lexpr
+ briDocByExactInlineOnly "HsRecFld" lexpr
HsOverLabel{} -> do
-- TODO
- unknownNodeError "HsOverLabel{}" lexpr
+ briDocByExactInlineOnly "HsOverLabel{}" lexpr
HsIPVar{} -> do
-- TODO
- unknownNodeError "HsOverLabel{}" lexpr
+ briDocByExactInlineOnly "HsOverLabel{}" lexpr
HsOverLit (OverLit olit _ _ _) -> do
allocateNode $ overLitValBriDoc olit
HsLit lit -> do
@@ -157,10 +157,10 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
]
HsAppType{} -> do
-- TODO
- unknownNodeError "HsAppType{}" lexpr
+ briDocByExactInlineOnly "HsAppType{}" lexpr
HsAppTypeOut{} -> do
-- TODO
- unknownNodeError "HsAppTypeOut{}" lexpr
+ briDocByExactInlineOnly "HsAppTypeOut{}" lexpr
OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do
let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)])
gather opExprList = \case
@@ -521,7 +521,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
docLit $ Text.pack "[]"
ExplicitPArr{} -> do
-- TODO
- unknownNodeError "ExplicitPArr{}" lexpr
+ briDocByExactInlineOnly "ExplicitPArr{}" lexpr
RecordCon lname _ _ (HsRecFields [] Nothing) -> do
let t = lrdrNameToText lname
docWrapNode lname $ docSeq
@@ -673,7 +673,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
]
ExprWithTySigOut{} -> do
-- TODO
- unknownNodeError "ExprWithTySigOut{}" lexpr
+ briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr
ArithSeq _ Nothing info ->
case info of
From e1 -> do
@@ -717,63 +717,63 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
, docLit $ Text.pack "]"
]
ArithSeq{} ->
- unknownNodeError "ArithSeq" lexpr
+ briDocByExactInlineOnly "ArithSeq" lexpr
PArrSeq{} -> do
-- TODO
- unknownNodeError "PArrSeq{}" lexpr
+ briDocByExactInlineOnly "PArrSeq{}" lexpr
HsSCC{} -> do
-- TODO
- unknownNodeError "HsSCC{}" lexpr
+ briDocByExactInlineOnly "HsSCC{}" lexpr
HsCoreAnn{} -> do
-- TODO
- unknownNodeError "HsCoreAnn{}" lexpr
+ briDocByExactInlineOnly "HsCoreAnn{}" lexpr
HsBracket{} -> do
-- TODO
- unknownNodeError "HsBracket{}" lexpr
+ briDocByExactInlineOnly "HsBracket{}" lexpr
HsRnBracketOut{} -> do
-- TODO
- unknownNodeError "HsRnBracketOut{}" lexpr
+ briDocByExactInlineOnly "HsRnBracketOut{}" lexpr
HsTcBracketOut{} -> do
-- TODO
- unknownNodeError "HsTcBracketOut{}" lexpr
+ briDocByExactInlineOnly "HsTcBracketOut{}" lexpr
HsSpliceE{} -> do
-- TODO
- unknownNodeError "HsSpliceE{}" lexpr
+ briDocByExactInlineOnly "HsSpliceE{}" lexpr
HsProc{} -> do
-- TODO
- unknownNodeError "HsProc{}" lexpr
+ briDocByExactInlineOnly "HsProc{}" lexpr
HsStatic{} -> do
-- TODO
- unknownNodeError "HsStatic{}" lexpr
+ briDocByExactInlineOnly "HsStatic{}" lexpr
HsArrApp{} -> do
-- TODO
- unknownNodeError "HsArrApp{}" lexpr
+ briDocByExactInlineOnly "HsArrApp{}" lexpr
HsArrForm{} -> do
-- TODO
- unknownNodeError "HsArrForm{}" lexpr
+ briDocByExactInlineOnly "HsArrForm{}" lexpr
HsTick{} -> do
-- TODO
- unknownNodeError "HsTick{}" lexpr
+ briDocByExactInlineOnly "HsTick{}" lexpr
HsBinTick{} -> do
-- TODO
- unknownNodeError "HsBinTick{}" lexpr
+ briDocByExactInlineOnly "HsBinTick{}" lexpr
HsTickPragma{} -> do
-- TODO
- unknownNodeError "HsTickPragma{}" lexpr
+ briDocByExactInlineOnly "HsTickPragma{}" lexpr
EWildPat{} -> do
docLit $ Text.pack "_"
EAsPat{} -> do
-- TODO
- unknownNodeError "EAsPat{}" lexpr
+ briDocByExactInlineOnly "EAsPat{}" lexpr
EViewPat{} -> do
-- TODO
- unknownNodeError "EViewPat{}" lexpr
+ briDocByExactInlineOnly "EViewPat{}" lexpr
ELazyPat{} -> do
-- TODO
- unknownNodeError "ELazyPat{}" lexpr
+ briDocByExactInlineOnly "ELazyPat{}" lexpr
HsWrap{} -> do
-- TODO
- unknownNodeError "HsWrap{}" lexpr
+ briDocByExactInlineOnly "HsWrap{}" lexpr
litBriDoc :: HsLit -> BriDocFInt
litBriDoc = \case
diff --git a/src/Language/Haskell/Brittany/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Layouters/Pattern.hs
index c0e53c9..599ac72 100644
--- a/src/Language/Haskell/Brittany/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Layouters/Pattern.hs
@@ -129,7 +129,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- #else
-- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n
-- #endif
- _ -> fmap return $ unknownNodeError "" lpat
+ _ -> fmap return $ briDocByExactInlineOnly "some unknown pattern" lpat
colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
diff --git a/src/Language/Haskell/Brittany/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Layouters/Stmt.hs
index 6252f52..f700f79 100644
--- a/src/Language/Haskell/Brittany/Layouters/Stmt.hs
+++ b/src/Language/Haskell/Brittany/Layouters/Stmt.hs
@@ -74,4 +74,4 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
BodyStmt expr _ _ _ -> do
expDoc <- docSharedWrapper layoutExpr expr
docAddBaseY BrIndentRegular $ expDoc
- _ -> unknownNodeError "" lstmt
+ _ -> briDocByExactInlineOnly "some unknown statement" lstmt
diff --git a/src/Language/Haskell/Brittany/Layouters/Type.hs b/src/Language/Haskell/Brittany/Layouters/Type.hs
index c7f76c1..96eb0e5 100644
--- a/src/Language/Haskell/Brittany/Layouters/Type.hs
+++ b/src/Language/Haskell/Brittany/Layouters/Type.hs
@@ -185,8 +185,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
)
]
- x@(HsQualTy (L _ []) _) ->
- unknownNodeError "HsQualTy [] _" x
+ (HsQualTy (L _ []) _) ->
+ briDocByExactInlineOnly "HsQualTy [] _" ltype
HsQualTy lcntxts@(L _ cntxts@(_:_)) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
@@ -396,7 +396,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
(docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])
]
HsOpTy{} -> -- TODO
- unknownNodeError "HsOpTy{}" ltype
+ briDocByExactInlineOnly "HsOpTy{}" ltype
-- HsOpTy typ1 opName typ2 -> do
-- -- TODO: these need some proper fixing. precedences don't add up.
-- -- maybe the parser just returns some trivial right recursion
@@ -511,7 +511,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
])
]
HsBangTy{} -> -- TODO
- unknownNodeError "HsBangTy{}" ltype
+ briDocByExactInlineOnly "HsBangTy{}" ltype
-- HsBangTy bang typ1 -> do
-- let bangStr = case bang of
-- HsSrcBang _ unpackness strictness ->
@@ -563,11 +563,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- , _layouter_ast = ltype
-- }
HsSpliceTy{} -> -- TODO
- unknownNodeError "" ltype
+ briDocByExactInlineOnly "" ltype
HsDocTy{} -> -- TODO
- unknownNodeError "" ltype
+ briDocByExactInlineOnly "" ltype
HsRecTy{} -> -- TODO
- unknownNodeError "" ltype
+ briDocByExactInlineOnly "" ltype
HsExplicitListTy _ typs -> do
typDocs <- docSharedWrapper layoutType `mapM` typs
docAlt
@@ -578,10 +578,10 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- TODO
]
HsExplicitTupleTy{} -> -- TODO
- unknownNodeError "" ltype
+ briDocByExactInlineOnly "" ltype
HsTyLit{} -> -- TODO
- unknownNodeError "" ltype
+ briDocByExactInlineOnly "" ltype
HsCoreTy{} -> -- TODO
- unknownNodeError "" ltype
+ briDocByExactInlineOnly "" ltype
HsWildCardTy _ ->
docLit $ Text.pack "_"
diff --git a/src/Language/Haskell/Brittany/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Transformations/Alt.hs
index d7997a6..8117c65 100644
--- a/src/Language/Haskell/Brittany/Transformations/Alt.hs
+++ b/src/Language/Haskell/Brittany/Transformations/Alt.hs
@@ -450,9 +450,9 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParNone -> mVs
_ -> LineModeInvalid
BDFForwardLineMode bd -> rec bd
- BDFExternal{} -> return
- $ LineModeValid
- $ VerticalSpacing 999 VerticalSpacingParNone False
+ BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of
+ [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
+ x -> traceShow x $ VerticalSpacing 999 VerticalSpacingParNone False
BDFAnnotationPrior _annKey bd -> rec bd
BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd
@@ -663,6 +663,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
mVs <- filterAndLimit <$> rec bd
return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForwardLineMode bd -> rec bd
+ BDFExternal _ _ _ txt | [t] <- Text.lines txt ->
+ return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
BDFExternal{} ->
return $ [] -- yes, we just assume that we cannot properly layout
-- this.
diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc
index 3a24199..ea97715 100644
--- a/srcinc/prelude.inc
+++ b/srcinc/prelude.inc
@@ -787,3 +787,6 @@ import Control.Monad.Trans.Maybe ( MaybeT (..)
)
import Language.Haskell.Brittany.Prelude
+
+import Data.Data ( toConstr
+ )