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

Use ExactPrintFallback for unknown constructs 

fixes #11
pull/13/head
Lennart Spitzner 2017-03-06 12:42:27 +01:00
parent 0a907c5594
commit 575d530188
10 changed files with 115 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src-unittests/TestUtils.hs
View File

@ -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 []
}

1
src/Language/Haskell/Brittany/Config.hs
View File

@ -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 ]

37
src/Language/Haskell/Brittany/Config/Types.hs
View File

@ -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)

36
src/Language/Haskell/Brittany/LayouterBasics.hs
View File

@ -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

52
src/Language/Haskell/Brittany/Layouters/Expr.hs
View File

@ -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

2
src/Language/Haskell/Brittany/Layouters/Pattern.hs
View File

@ -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

2
src/Language/Haskell/Brittany/Layouters/Stmt.hs
View File

@ -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

20
src/Language/Haskell/Brittany/Layouters/Type.hs
View File

@ -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 "_"

8
src/Language/Haskell/Brittany/Transformations/Alt.hs
View File

@ -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.

3
srcinc/prelude.inc
View File

@ -787,3 +787,6 @@ import Control.Monad.Trans.Maybe ( MaybeT (..)
)
import Language.Haskell.Brittany.Prelude
import Data.Data ( toConstr
)