Use ExactPrintFallback for unknown constructs

fixes #11

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

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 ]

src/Language/Haskell/Brittany/Config/Types.hs

@@ -67,6 +67,14 @@ data ErrorHandlingConfigF f = ErrorHandlingConfig
   { _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
@@ -307,6 +326,7 @@ staticDefaultConfig = Config
     { _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)
+  cZip f (ErrorHandlingConfig x1 x2 x3 x4)
-         (ErrorHandlingConfig y1 y2 y3) = ErrorHandlingConfig
+         (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)

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

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

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

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

src/Language/Haskell/Brittany/Layouters/Type.hs

@@ -185,8 +185,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
             ]
           )
       ]
-  x@(HsQualTy (L _ []) _) ->
+  (HsQualTy (L _ []) _) ->
-    unknownNodeError "HsQualTy [] _" x
+    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 "_"

src/Language/Haskell/Brittany/Transformations/Alt.hs

@@ -450,9 +450,9 @@ getSpacing !bridoc = rec bridoc
           VerticalSpacingParNone -> mVs
           _  -> LineModeInvalid
       BDFForwardLineMode bd -> rec bd
-      BDFExternal{} -> return
+      BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of
-        $ LineModeValid
+        [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
-        $ VerticalSpacing 999 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.

srcinc/prelude.inc

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