{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
module ReWire.Error
      ( SyntaxErrorT, AstError, Warning (..), Label
      , MonadError
      , mark
      , failAt, failAt', failAtWith, failInternal
      , relocateErr, relocatingTo, relocatingNoLocTo
      , failNowhere
      , warnAt
      , filePath
      , printError
      , runSyntaxError
      , PutMsg (..)
      ) where

import Prelude hiding ((<>), lines, unlines)

import ReWire.Annotation (Annotation (..), Annote, Span (..), annContext, primSpan, srcAnnote, noAnn)
import ReWire.Config (Config, noWarn, wError, loadPath)
import ReWire.Pretty (text, showt, Pretty (pretty), (<>), (<+>), vsep, Doc, defaultLayoutOptions, layoutSmart, renderStrict)
import ReWire.Orphans ()

import Control.Lens ((^.))
import Control.Monad (guard)
import Data.Char (toUpper, isUpper, isSpace)
import Data.Function (on)
import Data.List (nubBy)
import Data.Maybe (maybeToList)
import Control.Monad.Catch (MonadCatch (..), MonadThrow (..))
import Control.Monad.Except (MonadError (..), ExceptT (..), runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.State (StateT (..), MonadState (..))
import Control.Monad.Trans (MonadTrans (..))
import Data.Text (Text, pack)
import Prettyprinter (annotate)
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, bold)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.IO (stderr, hIsTerminalDevice)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Prettyprinter.Render.Terminal as Term

-- | A secondary location with an explanatory note, attached to an error to
--   point at a related part of the source (e.g. "first defined here").
type Label = (Annote, Text)

-- | An error: a primary location and message, plus optional secondary
--   labelled locations and suggested-fix hints.
data AstError = AstError !Annote !Text ![Label] ![Text]

class PutMsg a where
      putMsg :: Text -> a -> a

instance PutMsg AstError where
      putMsg :: Text -> AstError -> AstError
putMsg Text
msg (AstError Annote
an Text
_ [Label]
ls [Text]
hs) = Annote -> Text -> [Label] -> [Text] -> AstError
AstError Annote
an Text
msg [Label]
ls [Text]
hs

instance Pretty AstError where
      pretty :: forall ann. AstError -> Doc ann
pretty (AstError Annote
an Text
msg [Label]
labels [Text]
hints) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
            Severity -> Annote -> Text -> Doc ann
forall ann. Severity -> Annote -> Text -> Doc ann
plainDiag Severity
SevError Annote
an (Text -> [Text] -> Text
appendContext Text
msg ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Annote -> [Text]
annContext Annote
an)
                  Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Label -> Doc ann) -> [Label] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map ((Annote -> Text -> Doc ann) -> Label -> Doc ann
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Annote -> Text -> Doc ann) -> Label -> Doc ann)
-> (Annote -> Text -> Doc ann) -> Label -> Doc ann
forall a b. (a -> b) -> a -> b
$ Severity -> Annote -> Text -> Doc ann
forall ann. Severity -> Annote -> Text -> Doc ann
plainDiag Severity
SevNote) [Label]
labels [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Severity -> Annote -> Text -> Doc ann
forall ann. Severity -> Annote -> Text -> Doc ann
plainDiag Severity
SevNote Annote
noAnn) [Text]
hints

-- | A non-fatal diagnostic: printed to stderr when emitted (see 'warnAt'),
--   or promoted to an 'AstError' under -Werror.
data Warning = Warning !Annote !Text
      deriving (Warning -> Warning -> Bool
(Warning -> Warning -> Bool)
-> (Warning -> Warning -> Bool) -> Eq Warning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Warning -> Warning -> Bool
== :: Warning -> Warning -> Bool
$c/= :: Warning -> Warning -> Bool
/= :: Warning -> Warning -> Bool
Eq, Eq Warning
Eq Warning =>
(Warning -> Warning -> Ordering)
-> (Warning -> Warning -> Bool)
-> (Warning -> Warning -> Bool)
-> (Warning -> Warning -> Bool)
-> (Warning -> Warning -> Bool)
-> (Warning -> Warning -> Warning)
-> (Warning -> Warning -> Warning)
-> Ord Warning
Warning -> Warning -> Bool
Warning -> Warning -> Ordering
Warning -> Warning -> Warning
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Warning -> Warning -> Ordering
compare :: Warning -> Warning -> Ordering
$c< :: Warning -> Warning -> Bool
< :: Warning -> Warning -> Bool
$c<= :: Warning -> Warning -> Bool
<= :: Warning -> Warning -> Bool
$c> :: Warning -> Warning -> Bool
> :: Warning -> Warning -> Bool
$c>= :: Warning -> Warning -> Bool
>= :: Warning -> Warning -> Bool
$cmax :: Warning -> Warning -> Warning
max :: Warning -> Warning -> Warning
$cmin :: Warning -> Warning -> Warning
min :: Warning -> Warning -> Warning
Ord)

instance Pretty Warning where
      pretty :: forall ann. Warning -> Doc ann
pretty (Warning Annote
an Text
msg) = Severity -> Annote -> Text -> Doc ann
forall ann. Severity -> Annote -> Text -> Doc ann
plainDiag Severity
SevWarning Annote
an (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
appendContext Text
msg ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Annote -> [Text]
annContext Annote
an

-- | The severity of a diagnostic, controlling its label and colour.
data Severity = SevError | SevWarning | SevNote

sevLabel :: Severity -> Text
sevLabel :: Severity -> Text
sevLabel = \ case Severity
SevError -> Text
"error"; Severity
SevWarning -> Text
"warning"; Severity
SevNote -> Text
"note"

sevStyle :: Severity -> AnsiStyle
sevStyle :: Severity -> AnsiStyle
sevStyle = \ case
      Severity
SevError   -> Color -> AnsiStyle
color Color
Red     AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold
      Severity
SevWarning -> Color -> AnsiStyle
color Color
Magenta AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold
      Severity
SevNote    -> Color -> AnsiStyle
color Color
Cyan    AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold

-- | Style for the "file:line:col:" location header (bold, default foreground,
--   as GHC does).
locStyle :: AnsiStyle
locStyle :: AnsiStyle
locStyle = AnsiStyle
bold

-- | Style for the gutter: line numbers and the "|" separators.
gutterStyle :: AnsiStyle
gutterStyle :: AnsiStyle
gutterStyle = Color -> AnsiStyle
color Color
Blue

-- | A coloured text fragment.
styled :: AnsiStyle -> Text -> Doc AnsiStyle
styled :: AnsiStyle -> Text -> Doc AnsiStyle
styled AnsiStyle
s = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
s (Doc AnsiStyle -> Doc AnsiStyle)
-> (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
text

-- | Present a diagnostic message as a sentence: capitalise the first letter and
--   end with terminal punctuation (adding a period when none is present).
normalizeMsg :: Text -> Text
normalizeMsg :: Text -> Text
normalizeMsg Text
msg = case Text -> Maybe (Char, Text)
T.uncons Text
trimmed of
      Maybe (Char, Text)
Nothing     -> Text
trimmed
      Just (Char
c, Text
r) -> Text -> Text
punct (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ if Bool
capitalize then Char -> Text -> Text
T.cons (Char -> Char
toUpper Char
c) Text
r else Text
trimmed
      where trimmed :: Text
trimmed    = Text -> Text
T.stripEnd Text
msg
            -- Don't capitalise a message that opens with a code identifier
            -- (e.g. "rwPrimFinite: ...", "fromList: ..."): its first token
            -- already contains an upper-case letter.
            capitalize :: Bool
capitalize = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isUpper (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
trimmed
            punct :: Text -> Text
punct Text
t | Text -> Bool
T.null Text
t                             = Text
t
                    | HasCallStack => Text -> Char
Text -> Char
T.last Text
t Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'.', Char
':', Char
'!', Char
'?'] = Text
t
                    | Bool
otherwise                            = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

-- | The "file:line:col:" header for an annotation, or Nothing if it has no
--   usable source position.
locHeaderText :: Annote -> Maybe Text
locHeaderText :: Annote -> Maybe Text
locHeaderText Annote
an = case Annote -> Maybe Span
primSpan Annote
an of
      Just (Span FilePath
file (Int
r, Int
c) (Int, Int)
_) | Bool -> Bool
not (FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" Bool -> Bool -> Bool
&& Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1)
            -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall {a}. (Eq a, Num a, TextShow a) => a -> Text
num Int
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall {a}. (Eq a, Num a, TextShow a) => a -> Text
num Int
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
      Maybe Span
_   -> Maybe Text
forall a. Maybe a
Nothing
      where num :: a -> Text
num a
n = if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1 then Text
forall a. Monoid a => a
mempty else Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. TextShow a => a -> Text
showt a
n

-- | A diagnostic block, GHC-style: "file:line:col: severity:" on the header
--   line, the message indented below it, then the source excerpt with a caret.
--   On a terminal the location is bold, the severity label and the underlined
--   source (and its caret) take the severity colour, and the gutter is blue.
--   With no source lines available the excerpt is omitted.
diagBlock :: Severity -> Annote -> Text -> Maybe [Text] -> Doc AnsiStyle
diagBlock :: Severity -> Annote -> Text -> Maybe [Text] -> Doc AnsiStyle
diagBlock Severity
sev Annote
an Text
msg Maybe [Text]
msrc = [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
header Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
: [Doc AnsiStyle]
msgLines [Doc AnsiStyle] -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. Semigroup a => a -> a -> a
<> Maybe (Doc AnsiStyle) -> [Doc AnsiStyle]
forall a. Maybe a -> [a]
maybeToList Maybe (Doc AnsiStyle)
excerpt
      where loc :: Maybe Span
loc      = Annote -> Maybe Span
primSpan Annote
an
            gutterW :: Int
gutterW  = Int -> (Span -> Int) -> Maybe Span -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (\ (Span FilePath
_ (Int
l, Int
_) (Int, Int)
_) -> FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
l) Maybe Span
loc
            indent :: Text
indent   = Int -> Text -> Text
T.replicate (Int
gutterW Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
" "
            sevDoc :: Doc AnsiStyle
sevDoc   = AnsiStyle -> Text -> Doc AnsiStyle
styled (Severity -> AnsiStyle
sevStyle Severity
sev) (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Severity -> Text
sevLabel Severity
sev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
            header :: Doc AnsiStyle
header   = Doc AnsiStyle
-> (Text -> Doc AnsiStyle) -> Maybe Text -> Doc AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc AnsiStyle
sevDoc (\ Text
t -> AnsiStyle -> Text -> Doc AnsiStyle
styled AnsiStyle
locStyle Text
t Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
sevDoc) (Maybe Text -> Doc AnsiStyle) -> Maybe Text -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Text
locHeaderText Annote
an
            msgLines :: [Doc AnsiStyle]
msgLines = [ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
text Text
indent Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Text -> Doc AnsiStyle
styled AnsiStyle
bold Text
l | Text
l <- Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
normalizeMsg Text
msg ]
            excerpt :: Maybe (Doc AnsiStyle)
excerpt  = do
                  Span _ (sl, sc) (el, ec) <- Maybe Span
loc
                  ls <- msrc
                  guard $ sl >= 1 && sl <= length ls
                  let src    = [Text]
ls [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
!! (Int
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                      gutter = Int -> Text
forall a. TextShow a => a -> Text
showt Int
sl
                      blankG = Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
gutter) Text
" "
                      endCol = if Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sl then Int
ec else Text -> Int
T.length Text
src Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                      n      = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
endCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sc       -- width of the highlight
                      before = Int -> Text -> Text
T.take (Int
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
src
                      under  = Int -> Text -> Text
T.take Int
n (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Int
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
src
                      after  = Int -> Text -> Text
T.drop (Int
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Text
src
                      caret  = Int -> Text -> Text
T.replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
n Text
"^"
                  pure $ vsep [ styled gutterStyle $ blankG <> " |"
                              , styled gutterStyle (gutter <> " | ") <> text before <> styled (sevStyle sev) under <> text after
                              , styled gutterStyle (blankG <> " | ") <> styled (sevStyle sev) caret ]

-- | Like 'diagBlock' but a plain, colour-free 'Doc' with no source excerpt,
--   for the pure 'Pretty' rendering (e.g. round-trip test failures).
plainDiag :: Severity -> Annote -> Text -> Doc ann
plainDiag :: forall ann. Severity -> Annote -> Text -> Doc ann
plainDiag Severity
sev Annote
an Text
msg = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
forall {ann}. Doc ann
header Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [ Text -> Doc ann
forall ann. Text -> Doc ann
text Text
"  " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
l | Text
l <- Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
normalizeMsg Text
msg ]
      where header :: Doc ann
header = Doc ann -> (Text -> Doc ann) -> Maybe Text -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
forall {ann}. Doc ann
sevDoc (\ Text
t -> Text -> Doc ann
forall ann. Text -> Doc ann
text Text
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall {ann}. Doc ann
sevDoc) (Maybe Text -> Doc ann) -> Maybe Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Text
locHeaderText Annote
an
            sevDoc :: Doc ann
sevDoc = Text -> Doc ann
forall ann. Text -> Doc ann
text (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Severity -> Text
sevLabel Severity
sev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"

-- | Append a node's context breadcrumbs below its message, one per line.
appendContext :: Text -> [Text] -> Text
appendContext :: Text -> [Text] -> Text
appendContext Text
msg = \ case
      []  -> Text
msg
      [Text]
cs  -> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
cs

-- | The point of the newtype and all the annoying boilerplate is to
--   redefine the "fail" method of the Monad and MonadFail typeclasses.
newtype SyntaxErrorT ex m a = SyntaxErrorT { forall ex (m :: * -> *) a.
SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a
unwrap :: StateT ex (ExceptT ex m) a }
      deriving ((forall a b.
 (a -> b) -> SyntaxErrorT ex m a -> SyntaxErrorT ex m b)
-> (forall a b. a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a)
-> Functor (SyntaxErrorT ex m)
forall a b. a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
forall a b. (a -> b) -> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
forall ex (m :: * -> *) a b.
Functor m =>
a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
forall ex (m :: * -> *) a b.
Functor m =>
(a -> b) -> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall ex (m :: * -> *) a b.
Functor m =>
(a -> b) -> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
fmap :: forall a b. (a -> b) -> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
$c<$ :: forall ex (m :: * -> *) a b.
Functor m =>
a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
<$ :: forall a b. a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
Functor, Functor (SyntaxErrorT ex m)
Functor (SyntaxErrorT ex m) =>
(forall a. a -> SyntaxErrorT ex m a)
-> (forall a b.
    SyntaxErrorT ex m (a -> b)
    -> SyntaxErrorT ex m a -> SyntaxErrorT ex m b)
-> (forall a b c.
    (a -> b -> c)
    -> SyntaxErrorT ex m a
    -> SyntaxErrorT ex m b
    -> SyntaxErrorT ex m c)
-> (forall a b.
    SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m b)
-> (forall a b.
    SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a)
-> Applicative (SyntaxErrorT ex m)
forall a. a -> SyntaxErrorT ex m a
forall a b.
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
forall a b.
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m b
forall a b.
SyntaxErrorT ex m (a -> b)
-> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
forall a b c.
(a -> b -> c)
-> SyntaxErrorT ex m a
-> SyntaxErrorT ex m b
-> SyntaxErrorT ex m c
forall ex (m :: * -> *). Monad m => Functor (SyntaxErrorT ex m)
forall ex (m :: * -> *) a. Monad m => a -> SyntaxErrorT ex m a
forall ex (m :: * -> *) a b.
Monad m =>
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
forall ex (m :: * -> *) a b.
Monad m =>
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m b
forall ex (m :: * -> *) a b.
Monad m =>
SyntaxErrorT ex m (a -> b)
-> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
forall ex (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> SyntaxErrorT ex m a
-> SyntaxErrorT ex m b
-> SyntaxErrorT ex m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall ex (m :: * -> *) a. Monad m => a -> SyntaxErrorT ex m a
pure :: forall a. a -> SyntaxErrorT ex m a
$c<*> :: forall ex (m :: * -> *) a b.
Monad m =>
SyntaxErrorT ex m (a -> b)
-> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
<*> :: forall a b.
SyntaxErrorT ex m (a -> b)
-> SyntaxErrorT ex m a -> SyntaxErrorT ex m b
$cliftA2 :: forall ex (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> SyntaxErrorT ex m a
-> SyntaxErrorT ex m b
-> SyntaxErrorT ex m c
liftA2 :: forall a b c.
(a -> b -> c)
-> SyntaxErrorT ex m a
-> SyntaxErrorT ex m b
-> SyntaxErrorT ex m c
$c*> :: forall ex (m :: * -> *) a b.
Monad m =>
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m b
*> :: forall a b.
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m b
$c<* :: forall ex (m :: * -> *) a b.
Monad m =>
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
<* :: forall a b.
SyntaxErrorT ex m a -> SyntaxErrorT ex m b -> SyntaxErrorT ex m a
Applicative, Monad (SyntaxErrorT ex m)
Monad (SyntaxErrorT ex m) =>
(forall a. IO a -> SyntaxErrorT ex m a)
-> MonadIO (SyntaxErrorT ex m)
forall a. IO a -> SyntaxErrorT ex m a
forall ex (m :: * -> *). MonadIO m => Monad (SyntaxErrorT ex m)
forall ex (m :: * -> *) a. MonadIO m => IO a -> SyntaxErrorT ex m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall ex (m :: * -> *) a. MonadIO m => IO a -> SyntaxErrorT ex m a
liftIO :: forall a. IO a -> SyntaxErrorT ex m a
MonadIO, MonadThrow (SyntaxErrorT ex m)
MonadThrow (SyntaxErrorT ex m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 SyntaxErrorT ex m a
 -> (e -> SyntaxErrorT ex m a) -> SyntaxErrorT ex m a)
-> MonadCatch (SyntaxErrorT ex m)
forall e a.
(HasCallStack, Exception e) =>
SyntaxErrorT ex m a
-> (e -> SyntaxErrorT ex m a) -> SyntaxErrorT ex m a
forall ex (m :: * -> *).
MonadCatch m =>
MonadThrow (SyntaxErrorT ex m)
forall ex (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
SyntaxErrorT ex m a
-> (e -> SyntaxErrorT ex m a) -> SyntaxErrorT ex m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall ex (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
SyntaxErrorT ex m a
-> (e -> SyntaxErrorT ex m a) -> SyntaxErrorT ex m a
catch :: forall e a.
(HasCallStack, Exception e) =>
SyntaxErrorT ex m a
-> (e -> SyntaxErrorT ex m a) -> SyntaxErrorT ex m a
MonadCatch, Monad (SyntaxErrorT ex m)
Monad (SyntaxErrorT ex m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 e -> SyntaxErrorT ex m a)
-> MonadThrow (SyntaxErrorT ex m)
forall e a. (HasCallStack, Exception e) => e -> SyntaxErrorT ex m a
forall ex (m :: * -> *). MonadThrow m => Monad (SyntaxErrorT ex m)
forall ex (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> SyntaxErrorT ex m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall ex (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> SyntaxErrorT ex m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> SyntaxErrorT ex m a
MonadThrow, MonadState ex)

instance MonadTrans (SyntaxErrorT ex) where
      lift :: forall (m :: * -> *) a. Monad m => m a -> SyntaxErrorT ex m a
lift = StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a
forall ex (m :: * -> *) a.
StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a
SyntaxErrorT (StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a)
-> (m a -> StateT ex (ExceptT ex m) a)
-> m a
-> SyntaxErrorT ex m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT ex m a -> StateT ex (ExceptT ex m) a
forall (m :: * -> *) a. Monad m => m a -> StateT ex m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT ex m a -> StateT ex (ExceptT ex m) a)
-> (m a -> ExceptT ex m a) -> m a -> StateT ex (ExceptT ex m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT ex m a
forall (m :: * -> *) a. Monad m => m a -> ExceptT ex m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance (PutMsg ex, Monad m) => MonadFail (SyntaxErrorT ex m) where
      fail :: forall a. FilePath -> SyntaxErrorT ex m a
fail = Text -> SyntaxErrorT ex m a
forall ex (m :: * -> *) a.
(PutMsg ex, Monad m, MonadState ex m, MonadError ex m) =>
Text -> m a
failNowhere (Text -> SyntaxErrorT ex m a)
-> (FilePath -> Text) -> FilePath -> SyntaxErrorT ex m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack

instance Monad m => Monad (SyntaxErrorT ex m) where
      (SyntaxErrorT StateT ex (ExceptT ex m) a
m) >>= :: forall a b.
SyntaxErrorT ex m a
-> (a -> SyntaxErrorT ex m b) -> SyntaxErrorT ex m b
>>= a -> SyntaxErrorT ex m b
f = StateT ex (ExceptT ex m) b -> SyntaxErrorT ex m b
forall ex (m :: * -> *) a.
StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a
SyntaxErrorT (StateT ex (ExceptT ex m) b -> SyntaxErrorT ex m b)
-> StateT ex (ExceptT ex m) b -> SyntaxErrorT ex m b
forall a b. (a -> b) -> a -> b
$ StateT ex (ExceptT ex m) a
m StateT ex (ExceptT ex m) a
-> (a -> StateT ex (ExceptT ex m) b) -> StateT ex (ExceptT ex m) b
forall a b.
StateT ex (ExceptT ex m) a
-> (a -> StateT ex (ExceptT ex m) b) -> StateT ex (ExceptT ex m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SyntaxErrorT ex m b -> StateT ex (ExceptT ex m) b
forall ex (m :: * -> *) a.
SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a
unwrap (SyntaxErrorT ex m b -> StateT ex (ExceptT ex m) b)
-> (a -> SyntaxErrorT ex m b) -> a -> StateT ex (ExceptT ex m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SyntaxErrorT ex m b
f

instance Monad m => MonadError ex (SyntaxErrorT ex m) where
      throwError :: forall a. ex -> SyntaxErrorT ex m a
throwError ex
e = StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a
forall ex (m :: * -> *) a.
StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a
SyntaxErrorT (ex -> StateT ex (ExceptT ex m) a
forall a. ex -> StateT ex (ExceptT ex m) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ex
e)
      catchError :: forall a.
SyntaxErrorT ex m a
-> (ex -> SyntaxErrorT ex m a) -> SyntaxErrorT ex m a
catchError (SyntaxErrorT StateT ex (ExceptT ex m) a
m) ex -> SyntaxErrorT ex m a
f = StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a
forall ex (m :: * -> *) a.
StateT ex (ExceptT ex m) a -> SyntaxErrorT ex m a
SyntaxErrorT (StateT ex (ExceptT ex m) a
-> (ex -> StateT ex (ExceptT ex m) a) -> StateT ex (ExceptT ex m) a
forall a.
StateT ex (ExceptT ex m) a
-> (ex -> StateT ex (ExceptT ex m) a) -> StateT ex (ExceptT ex m) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError StateT ex (ExceptT ex m) a
m (SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a
forall ex (m :: * -> *) a.
SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a
unwrap (SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a)
-> (ex -> SyntaxErrorT ex m a) -> ex -> StateT ex (ExceptT ex m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ex -> SyntaxErrorT ex m a
f))

failAt :: (MonadError AstError m, Annotation an) => an -> Text -> m a
failAt :: forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt an
an Text
msg = AstError -> m a
forall a. AstError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AstError -> m a) -> AstError -> m a
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> [Label] -> [Text] -> AstError
AstError (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
an) Text
msg [] []

-- | Like 'failAt', but attach secondary labelled locations and/or hints.
failAtWith :: (MonadError AstError m, Annotation an) => an -> Text -> [Label] -> [Text] -> m a
failAtWith :: forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> [Label] -> [Text] -> m a
failAtWith an
an Text
msg [Label]
labels [Text]
hints = AstError -> m a
forall a. AstError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AstError -> m a) -> AstError -> m a
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> [Label] -> [Text] -> AstError
AstError (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
an) Text
msg [Label]
labels [Text]
hints

-- | Report a violated internal invariant: a bug in rwc itself, not a problem
--   with the user's program. Rendered with a "please report it" hint so the
--   message can't be mistaken for a complaint about the user's code.
failInternal :: (MonadError AstError m, Annotation an) => an -> Text -> m a
failInternal :: forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failInternal an
an Text
msg = an -> Text -> [Label] -> [Text] -> m a
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> [Label] -> [Text] -> m a
failAtWith an
an (Text
"internal error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg) []
      [Text
"this is a bug in rwc, not a problem with your program; please report it at https://github.com/rewire-hardware/ReWire/issues"]

-- | Emit a warning: printed to stderr immediately (so it isn't lost if a
--   later pass fails), suppressed by -w, or promoted to an error by -Werror
--   (which therefore fails on the *first* warning).
warnAt :: (MonadError AstError m, MonadIO m, Annotation an) => Config -> an -> Text -> m ()
warnAt :: forall (m :: * -> *) an.
(MonadError AstError m, MonadIO m, Annotation an) =>
Config -> an -> Text -> m ()
warnAt Config
conf an
an Text
msg
      | Config
confConfig -> Getting Bool Config Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Config Bool
Lens' Config Bool
wError = an -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt an
an (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [-Werror]"
      | Config
confConfig -> Getting Bool Config Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Config Bool
Lens' Config Bool
noWarn = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise    = [FilePath]
-> Severity -> Annote -> Text -> [Label] -> [Text] -> m ()
forall (m :: * -> *).
MonadIO m =>
[FilePath]
-> Severity -> Annote -> Text -> [Label] -> [Text] -> m ()
printDiag (Config
conf Config -> Getting [FilePath] Config [FilePath] -> [FilePath]
forall s a. s -> Getting a s a -> a
^. Getting [FilePath] Config [FilePath]
Lens' Config [FilePath]
loadPath) Severity
SevWarning (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
an) Text
msg [] []

-- | Like failAt, but include an extra bit of data on failure.
failAt' :: (MonadError (ex, AstError) m, Annotation an) => ex -> an -> Text -> m a
failAt' :: forall ex (m :: * -> *) an a.
(MonadError (ex, AstError) m, Annotation an) =>
ex -> an -> Text -> m a
failAt' ex
ex an
an Text
msg = (ex, AstError) -> m a
forall a. (ex, AstError) -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ex
ex, Annote -> Text -> [Label] -> [Text] -> AstError
AstError (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
an) Text
msg [] [])

-- | Re-point a diagnostic at a fallback location when it has none, or when it
--   resolves to a different source file than the fallback — typically because
--   the error surfaced inside inlined library code while compiling a user
--   definition. The original location, when it had one, is kept as a secondary
--   note so the expansion site stays visible.
relocateErr :: Annotation an => an -> AstError -> AstError
relocateErr :: forall an. Annotation an => an -> AstError -> AstError
relocateErr an
to e :: AstError
e@(AstError Annote
from Text
msg [Label]
labels [Text]
hints) = case Annote -> Maybe Span
primSpan (Annote -> Maybe Span) -> Annote -> Maybe Span
forall a b. (a -> b) -> a -> b
$ an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
to of
      Maybe Span
Nothing -> AstError
e
      Just Span
toSpan -> case Annote -> Maybe Span
primSpan Annote
from of
            Just Span
fromSpan | Span -> FilePath
spanFile Span
fromSpan FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> FilePath
spanFile Span
toSpan -> AstError
e
            Just Span
_                                              -> AstError
relocated
            Maybe Span
Nothing                                             -> Annote -> Text -> [Label] -> [Text] -> AstError
AstError (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
to) Text
msg [Label]
labels [Text]
hints
      where relocated :: AstError
relocated = Annote -> Text -> [Label] -> [Text] -> AstError
AstError (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
to) Text
msg ((Annote
from, Text
"In code expanded here:") Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
: [Label]
labels) [Text]
hints

-- | Run an action, relocating any error it raises to the given fallback
--   location (see 'relocateErr').
relocatingTo :: (MonadError AstError m, Annotation an) => an -> m a -> m a
relocatingTo :: forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> m a -> m a
relocatingTo an
to m a
m = m a
m m a -> (AstError -> m a) -> m a
forall a. m a -> (AstError -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (AstError -> m a
forall a. AstError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AstError -> m a) -> (AstError -> AstError) -> AstError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. an -> AstError -> AstError
forall an. Annotation an => an -> AstError -> AstError
relocateErr an
to)

-- | Give a fallback location only to diagnostics that have none, leaving
--   already-located errors untouched. Used at the top of the pipeline so that
--   a whole-program error (no single offending node) still names the file
--   being compiled.
relocateErrNoLoc :: Annotation an => an -> AstError -> AstError
relocateErrNoLoc :: forall an. Annotation an => an -> AstError -> AstError
relocateErrNoLoc an
to (AstError Annote
from Text
msg [Label]
labels [Text]
hints)
      | Maybe Span
Nothing <- Annote -> Maybe Span
primSpan Annote
from = Annote -> Text -> [Label] -> [Text] -> AstError
AstError (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
to) Text
msg [Label]
labels [Text]
hints
relocateErrNoLoc an
_ AstError
e = AstError
e

relocatingNoLocTo :: (MonadError AstError m, Annotation an) => an -> m a -> m a
relocatingNoLocTo :: forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> m a -> m a
relocatingNoLocTo an
to m a
m = m a
m m a -> (AstError -> m a) -> m a
forall a. m a -> (AstError -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (AstError -> m a
forall a. AstError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AstError -> m a) -> (AstError -> AstError) -> AstError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. an -> AstError -> AstError
forall an. Annotation an => an -> AstError -> AstError
relocateErrNoLoc an
to)

failNowhere :: (PutMsg ex, Monad m, MonadState ex m, MonadError ex m) => Text -> m a
failNowhere :: forall ex (m :: * -> *) a.
(PutMsg ex, Monad m, MonadState ex m, MonadError ex m) =>
Text -> m a
failNowhere Text
msg = m ex
forall s (m :: * -> *). MonadState s m => m s
get m ex -> (ex -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ex -> m a
forall a. ex -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ex -> m a) -> (ex -> ex) -> ex -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ex -> ex
forall a. PutMsg a => Text -> a -> a
putMsg Text
msg

-- | Print an error to stderr, GHC-style, with a source excerpt and a caret
--   under the offending region (plus any secondary "note" blocks) when the
--   files can be found on the load path.
printError :: MonadIO m => [FilePath] -> AstError -> m ()
printError :: forall (m :: * -> *). MonadIO m => [FilePath] -> AstError -> m ()
printError [FilePath]
dirs (AstError Annote
an Text
msg [Label]
labels [Text]
hints) = [FilePath]
-> Severity -> Annote -> Text -> [Label] -> [Text] -> m ()
forall (m :: * -> *).
MonadIO m =>
[FilePath]
-> Severity -> Annote -> Text -> [Label] -> [Text] -> m ()
printDiag [FilePath]
dirs Severity
SevError Annote
an Text
msg [Label]
labels [Text]
hints

-- | Render a diagnostic (its header, indented message, source excerpt, and any
--   secondary "note" blocks for labels and hints) to stderr, coloured when
--   stderr is a terminal. Source files are looked up along the search path.
printDiag :: MonadIO m => [FilePath] -> Severity -> Annote -> Text -> [Label] -> [Text] -> m ()
printDiag :: forall (m :: * -> *).
MonadIO m =>
[FilePath]
-> Severity -> Annote -> Text -> [Label] -> [Text] -> m ()
printDiag [FilePath]
dirs Severity
sev Annote
an Text
msg [Label]
labels [Text]
hints = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      primary <- [FilePath] -> Severity -> Annote -> Text -> IO (Doc AnsiStyle)
blockWithSource [FilePath]
dirs Severity
sev Annote
an (Text -> IO (Doc AnsiStyle)) -> Text -> IO (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
appendContext Text
msg ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Annote -> [Text]
annContext Annote
an
      -- Drop labels that resolve to the primary location (a "note" pointing at
      -- the error itself is just noise), and collapse labels that share a
      -- location into one (e.g. the relocation note and an explicit "first used
      -- here" landing on the same spot).
      labelBs <- mapM (uncurry $ blockWithSource dirs SevNote)
                       $ nubBy ((==) `on` (primSpan . fst))
                       $ filter ((primSpan an /=) . primSpan . fst) labels
      let hintBs = (Text -> Doc AnsiStyle) -> [Text] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (\ Text
h -> Severity -> Annote -> Text -> Maybe [Text] -> Doc AnsiStyle
diagBlock Severity
SevNote Annote
noAnn Text
h Maybe [Text]
forall a. Maybe a
Nothing) [Text]
hints
      colour  <- hIsTerminalDevice stderr
      T.hPutStr stderr $ (if colour then doc2Colour else doc2Text) (vsep $ primary : labelBs <> hintBs) <> "\n\n"

-- | A 'diagBlock' with the source lines read from the load path.
blockWithSource :: [FilePath] -> Severity -> Annote -> Text -> IO (Doc AnsiStyle)
blockWithSource :: [FilePath] -> Severity -> Annote -> Text -> IO (Doc AnsiStyle)
blockWithSource [FilePath]
dirs Severity
sev Annote
an Text
msg = do
      msrc <- IO (Maybe [Text])
-> (Span -> IO (Maybe [Text])) -> Maybe Span -> IO (Maybe [Text])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe [Text] -> IO (Maybe [Text])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Text]
forall a. Maybe a
Nothing) ([FilePath] -> FilePath -> IO (Maybe [Text])
locateSource [FilePath]
dirs (FilePath -> IO (Maybe [Text]))
-> (Span -> FilePath) -> Span -> IO (Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> FilePath
spanFile) (Maybe Span -> IO (Maybe [Text]))
-> Maybe Span -> IO (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Span
primSpan Annote
an
      pure $ diagBlock sev an msg msrc

-- | Read a source file, trying it directly then relative to each search dir.
locateSource :: [FilePath] -> FilePath -> IO (Maybe [Text])
locateSource :: [FilePath] -> FilePath -> IO (Maybe [Text])
locateSource [FilePath]
dirs FilePath
f = [FilePath] -> IO (Maybe [Text])
go ([FilePath] -> IO (Maybe [Text]))
-> [FilePath] -> IO (Maybe [Text])
forall a b. (a -> b) -> a -> b
$ FilePath
f FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
f) [FilePath]
dirs
      where go :: [FilePath] -> IO (Maybe [Text])
            go :: [FilePath] -> IO (Maybe [Text])
go []       = Maybe [Text] -> IO (Maybe [Text])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Text]
forall a. Maybe a
Nothing
            go (FilePath
c : [FilePath]
cs) = do
                  ex <- FilePath -> IO Bool
doesFileExist FilePath
c
                  if ex then Just . T.lines <$> T.readFile c else go cs

filePath :: FilePath -> Annote
filePath :: FilePath -> Annote
filePath FilePath
fp = FilePath -> (Int, Int) -> (Int, Int) -> Annote
srcAnnote FilePath
fp (-Int
1, -Int
1) (-Int
1, -Int
1)

runSyntaxError :: Monad m => SyntaxErrorT AstError m a -> m (Either AstError a)
runSyntaxError :: forall (m :: * -> *) a.
Monad m =>
SyntaxErrorT AstError m a -> m (Either AstError a)
runSyntaxError = AstError -> SyntaxErrorT AstError m a -> m (Either AstError a)
forall (m :: * -> *) ex a.
Monad m =>
ex -> SyntaxErrorT ex m a -> m (Either ex a)
runSyntaxError' (AstError -> SyntaxErrorT AstError m a -> m (Either AstError a))
-> AstError -> SyntaxErrorT AstError m a -> m (Either AstError a)
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> [Label] -> [Text] -> AstError
AstError Annote
noAnn Text
forall a. Monoid a => a
mempty [] []

runSyntaxError' :: Monad m => ex -> SyntaxErrorT ex m a -> m (Either ex a)
runSyntaxError' :: forall (m :: * -> *) ex a.
Monad m =>
ex -> SyntaxErrorT ex m a -> m (Either ex a)
runSyntaxError' ex
ex0 = ExceptT ex m a -> m (Either ex a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ex m a -> m (Either ex a))
-> (SyntaxErrorT ex m a -> ExceptT ex m a)
-> SyntaxErrorT ex m a
-> m (Either ex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, ex) -> a) -> ExceptT ex m (a, ex) -> ExceptT ex m a
forall a b. (a -> b) -> ExceptT ex m a -> ExceptT ex m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, ex) -> a
forall a b. (a, b) -> a
fst (ExceptT ex m (a, ex) -> ExceptT ex m a)
-> (SyntaxErrorT ex m a -> ExceptT ex m (a, ex))
-> SyntaxErrorT ex m a
-> ExceptT ex m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT ex (ExceptT ex m) a -> ex -> ExceptT ex m (a, ex))
-> ex -> StateT ex (ExceptT ex m) a -> ExceptT ex m (a, ex)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ex (ExceptT ex m) a -> ex -> ExceptT ex m (a, ex)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ex
ex0 (StateT ex (ExceptT ex m) a -> ExceptT ex m (a, ex))
-> (SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a)
-> SyntaxErrorT ex m a
-> ExceptT ex m (a, ex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a
forall ex (m :: * -> *) a.
SyntaxErrorT ex m a -> StateT ex (ExceptT ex m) a
unwrap

mark :: (MonadState AstError m, Annotation an) => an -> m ()
mark :: forall (m :: * -> *) an.
(MonadState AstError m, Annotation an) =>
an -> m ()
mark an
an = AstError -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (AstError -> m ()) -> AstError -> m ()
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> [Label] -> [Text] -> AstError
AstError (an -> Annote
forall a. Annotation a => a -> Annote
toAnnote an
an) Text
forall a. Monoid a => a
mempty [] []

doc2Text :: Doc a -> Text
doc2Text :: forall a. Doc a -> Text
doc2Text = SimpleDocStream a -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream a -> Text)
-> (Doc a -> SimpleDocStream a) -> Doc a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions

-- | Render with ANSI colour escapes (for a terminal).
doc2Colour :: Doc AnsiStyle -> Text
doc2Colour :: Doc AnsiStyle -> Text
doc2Colour = SimpleDocStream AnsiStyle -> Text
Term.renderStrict (SimpleDocStream AnsiStyle -> Text)
-> (Doc AnsiStyle -> SimpleDocStream AnsiStyle)
-> Doc AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions