Give Notice a parameter for the doc highlights.

fused-effects-parser.cabal

@@ -69,6 +69,7 @@ test-suite test
     , fused-effects-parser
     , hedgehog ^>= 1
     , parsers
+    , prettyprinter-ansi-terminal
     , tasty ^>= 1.2
     , tasty-hedgehog ^>= 1
     , tasty-hunit ^>= 0.10

src/Control/Carrier/Parser/Church.hs

@@ -58,17 +58,17 @@ import           Text.Parser.Char (CharParsing(..))
 import           Text.Parser.Combinators
 import           Text.Parser.Token (TokenParsing)
 
-runParserWithString :: Has (Throw Notice.Notice) sig m => Pos -> String -> ParserC m a -> m a
+runParserWithString :: Has (Throw (Notice.Notice AnsiStyle)) sig m => Pos -> String -> ParserC m a -> m a
 runParserWithString pos str = runParserWith Nothing (Input pos str)
 {-# INLINE runParserWithString #-}
 
-runParserWithFile :: (Has (Throw Notice.Notice) sig m, MonadIO m) => FilePath -> ParserC m a -> m a
+runParserWithFile :: (Has (Throw (Notice.Notice AnsiStyle)) sig m, MonadIO m) => FilePath -> ParserC m a -> m a
 runParserWithFile path p = do
   input <- liftIO (readFile path)
   runParserWith (Just path) (Input (Pos 0 0) input) p
 {-# INLINE runParserWithFile #-}
 
-runParserWith :: Has (Throw Notice.Notice) sig m => Maybe FilePath -> Input -> ParserC m a -> m a
+runParserWith :: Has (Throw (Notice.Notice AnsiStyle)) sig m => Maybe FilePath -> Input -> ParserC m a -> m a
 runParserWith path input = runParser (const pure) failure failure input
   where
   src = sourceFromString path (str input)
@@ -305,7 +305,7 @@ expected_ :: Lens' Err (Set String)
 expected_ = lens expected $ \ i expected -> i{ expected }
 {-# INLINE expected_ #-}
 
-errToNotice :: Source -> Err -> Notice.Notice
+errToNotice :: Source -> Err -> Notice.Notice AnsiStyle
 errToNotice source Err{ input = Input pos _, reason, expected } = Notice.Notice
   { level   = Just Notice.Error
   , excerpt = Excerpt (Source.path source) (source ! pos) (Span pos pos)

src/Control/Effect/Parser/GHCI.hs

@@ -14,7 +14,7 @@ import Text.Parser.Char
 import Text.Parser.Combinators
 import Text.Parser.Token
 
-parse :: Show a => ParserC (Either Notice) a -> String -> IO ()
+parse :: Show a => ParserC (Either (Notice AnsiStyle)) a -> String -> IO ()
 parse p s = do
   let v = runParserWithString (Pos 0 0) s p
   either (putDoc . (<> line) . prettyNotice) print v

src/Control/Effect/Parser/Notice.hs

@@ -31,27 +31,27 @@ prettyLevel = \case
   Error -> red     (pretty "error")
 
 
-data Notice = Notice
+data Notice a = Notice
   { level   :: !(Maybe Level)
   , excerpt :: {-# UNPACK #-} !Excerpt
-  , reason  :: !(Doc AnsiStyle)
-  , context :: ![Doc AnsiStyle]
+  , reason  :: !(Doc a)
+  , context :: ![Doc a]
   }
   deriving (Show)
 
-level_ :: Lens' Notice (Maybe Level)
+level_ :: Lens' (Notice AnsiStyle) (Maybe Level)
 level_ = lens level $ \ n level -> n{ level }
 
-excerpt_ :: Lens' Notice Excerpt
+excerpt_ :: Lens' (Notice AnsiStyle) Excerpt
 excerpt_ = lens excerpt $ \ n excerpt -> n{ excerpt }
 
-reason_ :: Lens' Notice (Doc AnsiStyle)
+reason_ :: Lens' (Notice AnsiStyle) (Doc AnsiStyle)
 reason_ = lens reason $ \ n reason -> n{ reason }
 
-context_ :: Lens' Notice [Doc AnsiStyle]
+context_ :: Lens' (Notice AnsiStyle) [Doc AnsiStyle]
 context_ = lens context $ \ n context -> n{ context }
 
-prettyNotice :: Notice -> Doc AnsiStyle
+prettyNotice :: Notice AnsiStyle -> Doc AnsiStyle
 prettyNotice (Notice level (Excerpt path line span) reason context) = vsep
   ( nest 2 (group (fillSep
     [ bold (pretty (fromMaybe "(interactive)" path)) <> colon <> pos (Span.start span) <> colon <> foldMap ((space <>) . (<> colon) . prettyLevel) level

test/Test.hs

@@ -16,6 +16,7 @@ import           Hedgehog
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 import           Prelude hiding (lines)
+import           Prettyprinter.Render.Terminal (AnsiStyle)
 import           Test.Tasty
 import           Test.Tasty.Hedgehog
 import           Test.Tasty.HUnit
@@ -73,7 +74,7 @@ parserTests = testGroup "ParserC (Church)"
   ]
 
 
-parsesInto :: (Eq a, Show a) => ParserC (Either Notice) a -> String -> a -> Assertion
+parsesInto :: (Eq a, Show a) => ParserC (Either (Notice AnsiStyle)) a -> String -> a -> Assertion
 parsesInto p s expected = case runParserWithString (Pos 0 0) s p of
   Left  err    -> assertFailure (show err)
   Right actual -> actual @?= expected