From 575d53018881cd1fa3432d3066143335674c4a20 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 6 Mar 2017 12:42:27 +0100 Subject: [PATCH] Use ExactPrintFallback for unknown constructs fixes #11 --- src-unittests/TestUtils.hs | 4 +- src/Language/Haskell/Brittany/Config.hs | 1 + src/Language/Haskell/Brittany/Config/Types.hs | 37 ++++++++++--- .../Haskell/Brittany/LayouterBasics.hs | 36 +++++++++++++ .../Haskell/Brittany/Layouters/Expr.hs | 52 +++++++++---------- .../Haskell/Brittany/Layouters/Pattern.hs | 2 +- .../Haskell/Brittany/Layouters/Stmt.hs | 2 +- .../Haskell/Brittany/Layouters/Type.hs | 20 +++---- .../Haskell/Brittany/Transformations/Alt.hs | 8 +-- srcinc/prelude.inc | 3 ++ 10 files changed, 115 insertions(+), 50 deletions(-) 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 + )