Include exact location when printing ErrorUnknownNode

pull/185/head
Lennart Spitzner 2018-09-18 00:23:23 +02:00
parent b2795482fa
commit 37e4225c49
4 changed files with 24 additions and 17 deletions

View File

@ -15,6 +15,11 @@ 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 qualified Data.Monoid
import GHC ( GenLocated(L) )
import Outputable ( Outputable(..)
, showSDocUnsafe
)
import Text.Read ( Read(..) ) import Text.Read ( Read(..) )
import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec import qualified Text.ParserCombinators.ReadPrec as ReadPrec
@ -285,8 +290,6 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
return $ Right True return $ Right True
CPPModeNowarn -> return $ Right True CPPModeNowarn -> return $ Right True
else return $ Right False else return $ Right False
let
inputPathName = maybe "stdin" (("file " <>) . show) inputPathM
(parseResult, originalContents) <- case inputPathM of (parseResult, originalContents) <- case inputPathM of
Nothing -> do Nothing -> do
-- TODO: refactor this hack to not be mixed into parsing logic -- TODO: refactor this hack to not be mixed into parsing logic
@ -384,10 +387,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
(ErrorInput str : _) -> do (ErrorInput str : _) -> do
putErrorLn $ "ERROR: parse error: " ++ str putErrorLn $ "ERROR: parse error: " ++ str
uns@(ErrorUnknownNode{} : _) -> do uns@(ErrorUnknownNode{} : _) -> do
putErrorLn $ "ERROR: encountered unknown syntactical constructs when parsing " <> inputPathName <> ":" putErrorLn $ "ERROR: encountered unknown syntactical constructs:"
uns `forM_` \case uns `forM_` \case
ErrorUnknownNode str ast -> do ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn str putErrorLn $ str <> " at " <> showSDocUnsafe (ppr loc)
when when
( config ( config
& _conf_debug & _conf_debug

View File

@ -694,7 +694,10 @@ docEnsureIndent
docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
unknownNodeError unknownNodeError
:: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered :: Data.Data.Data ast
=> String
-> GenLocated GHC.SrcSpan 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 -}"

View File

@ -27,7 +27,7 @@ import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan, noSrcSpan )
import HsSyn import HsSyn
import Name import Name
import BasicTypes ( InlinePragma(..) import BasicTypes ( InlinePragma(..)
@ -202,9 +202,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
-- x@(HsValBinds (ValBindsIn{})) -> -- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
HsValBinds (ValBindsIn bindlrs sigs) -> do HsValBinds (ValBindsIn bindlrs sigs) -> do
let let unordered =
unordered [ BagBind b | b <- Data.Foldable.toList bindlrs ]
= [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ] ++ [ BagSig s | s <- sigs ]
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
@ -213,8 +212,10 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
return $ Just $ docs return $ Just $ docs
x@(HsValBinds (ValBindsOut _binds _lsigs)) -> x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
-- i _think_ this case never occurs in non-processed ast -- i _think_ this case never occurs in non-processed ast
Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x Just . (: []) <$> unknownNodeError "HsValBinds ValBindsOut{}"
x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x (L noSrcSpan x)
x@(HsIPBinds _ipBinds) ->
Just . (: []) <$> unknownNodeError "HsIPBinds" (L noSrcSpan x)
EmptyLocalBinds -> return $ Nothing EmptyLocalBinds -> return $ Nothing
-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is

View File

@ -17,7 +17,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId, SrcSpan )
import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment )
import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey ) import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey )
@ -134,7 +134,7 @@ data BrittanyError
-- output and second the corresponding, ill-formed input. -- output and second the corresponding, ill-formed input.
| LayoutWarning String | LayoutWarning String
-- ^ some warning -- ^ some warning
| forall ast . Data.Data.Data ast => ErrorUnknownNode String ast | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast)
-- ^ internal error: pretty-printing is not implemented for type of node -- ^ internal error: pretty-printing is not implemented for type of node
-- in the syntax-tree -- in the syntax-tree
| ErrorOutputCheck | ErrorOutputCheck