diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e6256ec..b6987b5 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -61,6 +61,11 @@ 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. +-- +-- Note that the ghc parsing function used internally currently is wrapped in +-- `mask_`, so cannot be killed easily. If you don't control the input, you +-- may wish to put some proper upper bound on the input's size as a timeout +-- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configRaw inputText = runExceptT $ do let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 081032d..d0f481c 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -37,6 +37,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Data.Generics as SYB + +import Control.Exception -- import Data.Generics.Schemes @@ -85,7 +87,14 @@ parseModuleFromString -> String -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleFromString args fp dynCheck str = - ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do + -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will + -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we + -- cannot kill the parsing thread - not very nice. But i'll + -- optimistically assume that most of the time brittany uses noticable or + -- longer time, the majority of the time is not spend in parsing, but in + -- bridoc transformation stuff. + -- (reminder to update note on `parsePrintModule` if this changes.) + mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)