diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index b1035f8..c4e055b 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -159,22 +159,22 @@ mainCmdParser helpDesc = do else pPrintModuleAndCheck config anns parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) else (ews, outRaw) - let customErrOrder LayoutErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder LayoutErrorOutputCheck{} = 1 - customErrOrder LayoutErrorUnusedComment{} = 2 - customErrOrder LayoutErrorUnknownNode{} = 3 + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 when (not $ null errsWarns) $ do let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns groupedErrsWarns `forM_` \case - (LayoutErrorOutputCheck{}:_) -> do + (ErrorOutputCheck{}:_) -> do putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." - (LayoutErrorInput str:_) -> do + (ErrorInput str:_) -> do putStrErrLn $ "ERROR: parse error: " ++ str - uns@(LayoutErrorUnknownNode{}:_) -> do + uns@(ErrorUnknownNode{}:_) -> do putStrErrLn $ "ERROR: encountered unknown syntactical constructs:" uns `forM_` \case - LayoutErrorUnknownNode str ast -> do + ErrorUnknownNode str ast -> do putStrErrLn str when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do putStrErrLn $ " " ++ show (astToDoc ast) @@ -184,7 +184,7 @@ mainCmdParser helpDesc = do warns `forM_` \case LayoutWarning str -> putStrErrLn str _ -> error "cannot happen (TM)" - unused@(LayoutErrorUnusedComment{}:_) -> do + unused@(ErrorUnusedComment{}:_) -> do putStrErrLn $ "Error: detected unprocessed comments." ++ " The transformation output will most likely" @@ -192,8 +192,8 @@ mainCmdParser helpDesc = do ++ " present in the input haskell source file." putStrErrLn $ "Affected are the following comments:" unused `forM_` \case - LayoutErrorUnusedComment str -> putStrErrLn str - _ -> error "cannot happen (TM)" + ErrorUnusedComment str -> putStrErrLn str + _ -> error "cannot happen (TM)" [] -> error "cannot happen" -- TODO: don't output anything when there are errors unless user -- adds some override? diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index ac0b90d..67bae06 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -3,7 +3,7 @@ module Language.Haskell.Brittany ( pureModuleTransform , CConfig - , LayoutError(..) + , BrittanyError(..) ) where diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 5bbfc54..d799290 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -60,7 +60,7 @@ import qualified GHC.LanguageExtensions.Type as GHC -- -- Note that this function ignores/resets all config values regarding -- debugging, i.e. it will never use `trace`/write to stderr. -pureModuleTransform :: CConfig Option -> Text -> IO (Either [LayoutError] Text) +pureModuleTransform :: CConfig Option -> Text -> IO (Either [BrittanyError] Text) pureModuleTransform oConfigRaw inputText = runEitherT $ do let configRaw = cZipWith fromOptionIdentity staticDefaultConfig oConfigRaw let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } @@ -87,7 +87,7 @@ pureModuleTransform oConfigRaw inputText = runEitherT $ do cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> left $ [LayoutErrorInput err] + Left err -> left $ [ErrorInput err] Right x -> pure $ x (errsWarns, outputTextL) <- do let omitCheck = @@ -103,21 +103,19 @@ pureModuleTransform oConfigRaw inputText = runEitherT $ do pure $ if hackAroundIncludes then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) else (ews, outRaw) - let customErrOrder LayoutErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder LayoutErrorOutputCheck{} = 1 - customErrOrder LayoutErrorUnusedComment{} = 2 - customErrOrder LayoutErrorUnknownNode{} = 3 + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) True -> not $ null errsWarns - if hasErrors - then left $ errsWarns - else pure $ TextL.toStrict outputTextL + if hasErrors then left $ errsWarns else pure $ TextL.toStrict outputTextL --- LayoutErrors can be non-fatal warnings, thus both are returned instead +-- BrittanyErrors can be non-fatal warnings, thus both are returned instead -- of an Either. -- This should be cleaned up once it is clear what kinds of errors really -- can occur. @@ -125,7 +123,7 @@ pPrintModule :: Config -> ExactPrint.Types.Anns -> GHC.ParsedSource - -> ([LayoutError], TextL.Text) + -> ([BrittanyError], TextL.Text) pPrintModule conf anns parsedModule = let ((out, errs), debugStrings) = @@ -160,7 +158,7 @@ pPrintModuleAndCheck :: Config -> ExactPrint.Types.Anns -> GHC.ParsedSource - -> IO ([LayoutError], TextL.Text) + -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf anns parsedModule = do let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let (errs, output) = pPrintModule conf anns parsedModule @@ -169,7 +167,7 @@ pPrintModuleAndCheck conf anns parsedModule = do (\_ -> return $ Right ()) (TextL.unpack output) let errs' = errs ++ case parseResult of - Left{} -> [LayoutErrorOutputCheck] + Left{} -> [ErrorOutputCheck] Right{} -> [] return (errs', output) @@ -193,15 +191,13 @@ parsePrintModule conf filename input = do return $ if null errs then Right $ TextL.toStrict $ ltext else - let - errStrs = errs <&> \case - LayoutErrorInput str -> str - LayoutErrorUnusedComment str -> str - LayoutWarning str -> str - LayoutErrorUnknownNode str _ -> str - LayoutErrorOutputCheck -> "Output is not syntactically valid." - in - Left $ "pretty printing error(s):\n" ++ List.unlines errStrs + let errStrs = errs <&> \case + ErrorInput str -> str + ErrorUnusedComment str -> str + LayoutWarning str -> str + ErrorUnknownNode str _ -> str + ErrorOutputCheck -> "Output is not syntactically valid." + in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- this approach would for with there was a pure GHC.parseDynamicFilePragma. @@ -234,7 +230,7 @@ parsePrintModule conf filename input = do -- if (not $ null errs) -- then do -- let errStrs = errs <&> \case --- LayoutErrorUnusedComment str -> str +-- ErrorUnusedComment str -> str -- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- else return $ TextL.toStrict $ Text.Builder.toLazyText out @@ -396,6 +392,6 @@ layoutBriDoc ast briDoc = do let remainingComments = extractAllComments =<< Map.elems (_lstate_comments state') remainingComments - `forM_` (fst .> show .> LayoutErrorUnusedComment .> (:[]) .> mTell) + `forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell) return $ () diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 7ef4123..5314fcf 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -156,7 +156,7 @@ briDocByExactInlineOnly infoStr ast = do exactPrinted let errorAction = do - mTell $ [LayoutErrorUnknownNode infoStr ast] + mTell $ [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of (ExactPrintFallbackModeNever, _ ) -> errorAction @@ -607,7 +607,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do - mTell $ [LayoutErrorUnknownNode infoStr ast] + mTell $ [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 5420e7b..08cd750 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -28,7 +28,7 @@ import Data.Generics.Uniplate.Direct as Uniplate -type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [LayoutError], Seq String] '[] a +type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] a data LayoutState = LayoutState { _lstate_baseYs :: [Int] @@ -114,17 +114,17 @@ instance Show LayoutState where -- , _lsettings_initialAnns :: ExactPrint.Anns -- } -data LayoutError - = LayoutErrorInput String +data BrittanyError + = ErrorInput String -- ^ parsing failed - | LayoutErrorUnusedComment String + | ErrorUnusedComment String -- ^ internal error: some comment went missing | LayoutWarning String -- ^ some warning - | forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast + | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast -- ^ internal error: pretty-printing is not implemented for type of node -- in the syntax-tree - | LayoutErrorOutputCheck + | ErrorOutputCheck -- ^ checking the output for syntactic validity failed data BriSpacing = BriSpacing @@ -187,7 +187,7 @@ data BrIndent = BrIndentNone | BrIndentSpecial Int deriving (Eq, Ord, Typeable, Data.Data.Data, Show) -type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[LayoutError], Seq String] '[NodeAllocIndex] +type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex] type ToBriDoc (sym :: * -> *) = Located (sym RdrName) -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered