Merge pull request #273 from lspitzner/error-handling

Error handling

src-brittany/Main.hs

@@ -325,7 +325,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
     case parseResult of
       Left left -> do
         putErrorLn "parse error:"
-        putErrorLn $ show left
+        putErrorLn left
         ExceptT.throwE 60
       Right (anns, parsedSource, hasCPP) -> do
         (inlineConf, perItemConf) <-
@@ -374,10 +374,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
                 else pure out
               pure $ (ews, out')
         let customErrOrder ErrorInput{}         = 4
-            customErrOrder LayoutWarning{}      = 0 :: Int
+            customErrOrder LayoutWarning{}      = -1 :: Int
             customErrOrder ErrorOutputCheck{}   = 1
             customErrOrder ErrorUnusedComment{} = 2
-            customErrOrder ErrorUnknownNode{}   = 3
+            customErrOrder ErrorUnknownNode{}   = -2 :: Int
             customErrOrder ErrorMacroConfig{}   = 5
         when (not $ null errsWarns) $ do
           let groupedErrsWarns =
@@ -392,10 +392,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
             (ErrorInput str : _) -> do
               putErrorLn $ "ERROR: parse error: " ++ str
             uns@(ErrorUnknownNode{} : _) -> do
-              putErrorLn $ "ERROR: encountered unknown syntactical constructs:"
+              putErrorLn $ "WARNING: encountered unknown syntactical constructs:"
               uns `forM_` \case
                 ErrorUnknownNode str ast@(L loc _) -> do
-                  putErrorLn $ str <> " at " <> showSDocUnsafe (ppr loc)
+                  putErrorLn $ "  " <> str <> " at " <> showSDocUnsafe (ppr loc)
                   when
                       ( config
                       & _conf_debug
@@ -405,6 +405,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
                     $ do
                         putErrorLn $ "  " ++ show (astToDoc ast)
                 _ -> error "cannot happen (TM)"
+              putErrorLn "  -> falling back on exactprint for this element of the module"
             warns@(LayoutWarning{} : _) -> do
               putErrorLn $ "WARNINGS:"
               warns `forM_` \case

src/Language/Haskell/Brittany/Internal.hs

@@ -460,9 +460,15 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
 
     let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
     toLocal config' filteredAnns $ do
-      bd <- briDocMToPPM $ if exactprintOnly
+      bd <- if exactprintOnly
-        then briDocByExactNoComment decl
+        then briDocMToPPM $ briDocByExactNoComment decl
-        else layoutDecl decl
+        else do
+          (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl
+          mTell debugs
+          mTell errs
+          if null errs
+            then pure r
+            else briDocMToPPM $ briDocByExactNoComment decl
       layoutBriDoc bd
 
   let finalComments = filter

src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs

@@ -123,7 +123,7 @@ parseModuleFromString args fp dynCheck str =
     dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
     let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
     case res of
-      Left  (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err
+      Left  (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err
       Right (a   , m  ) -> pure (a, m, dynCheckRes)
 
 

src/Language/Haskell/Brittany/Internal/LayouterBasics.hs

@@ -62,6 +62,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , docTick
   , spacifyDocs
   , briDocMToPPM
+  , briDocMToPPMInner
   , allocateNode
   , docSharedWrapper
   , hasAnyCommentsBelow
@@ -814,6 +815,13 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
 
 briDocMToPPM :: ToBriDocM a -> PPMLocal a
 briDocMToPPM m = do
+  (x, errs, debugs) <- briDocMToPPMInner m
+  mTell debugs
+  mTell errs
+  return x
+
+briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
+briDocMToPPMInner m = do
   readers <- MultiRWSS.mGetRawR
   let ((x, errs), debugs) =
         runIdentity
@@ -823,9 +831,7 @@ briDocMToPPM m = do
           $ MultiRWSS.withMultiWriterAW
           $ MultiRWSS.withMultiWriterAW
           $ m
-  mTell debugs
+  pure (x, errs, debugs)
-  mTell errs
-  return x
 
 docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)
 docSharedWrapper f x = return <$> f x

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

@@ -215,7 +215,10 @@ data BrIndent = BrIndentNone
               | BrIndentSpecial Int
   deriving (Eq, Ord, Typeable, Data.Data.Data, Show)
 
-type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex]
+type ToBriDocM = MultiRWSS.MultiRWS
+                   '[Config, Anns] -- reader
+                   '[[BrittanyError], Seq String] -- writer
+                   '[NodeAllocIndex] -- state
 
 type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
 type ToBriDoc' sym            = Located sym         -> ToBriDocM BriDocNumbered