module Language.Futhark.Warnings
( Warnings,
anyWarnings,
singleWarning,
singleWarning',
listWarnings,
prettyWarnings,
)
where
import Data.List (sortOn)
import Data.Monoid
import Futhark.Util.Loc
import Futhark.Util.Pretty
import Language.Futhark.Core (locText, prettyStacktrace)
import Prelude
newtype Warnings = Warnings [(SrcLoc, [SrcLoc], Doc ())]
instance Semigroup Warnings where
Warnings [(SrcLoc, [SrcLoc], Doc ())]
ws1 <> :: Warnings -> Warnings -> Warnings
<> Warnings [(SrcLoc, [SrcLoc], Doc ())]
ws2 = [(SrcLoc, [SrcLoc], Doc ())] -> Warnings
Warnings forall a b. (a -> b) -> a -> b
$ [(SrcLoc, [SrcLoc], Doc ())]
ws1 forall a. Semigroup a => a -> a -> a
<> [(SrcLoc, [SrcLoc], Doc ())]
ws2
instance Monoid Warnings where
mempty :: Warnings
mempty = [(SrcLoc, [SrcLoc], Doc ())] -> Warnings
Warnings forall a. Monoid a => a
mempty
prettyWarnings :: Warnings -> Doc AnsiStyle
prettyWarnings :: Warnings -> Doc AnsiStyle
prettyWarnings (Warnings []) = forall a. Monoid a => a
mempty
prettyWarnings (Warnings [(SrcLoc, [SrcLoc], Doc ())]
ws) =
forall a. [Doc a] -> Doc a
stack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {ann}. Located a => (a, [a], Doc ann) -> Doc AnsiStyle
onWarning) forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Loc -> (FilePath, Int)
rep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. Located a => (a, b, c) -> Loc
wloc) [(SrcLoc, [SrcLoc], Doc ())]
ws
where
wloc :: (a, b, c) -> Loc
wloc (a
x, b
_, c
_) = forall a. Located a => a -> Loc
locOf a
x
rep :: Loc -> (FilePath, Int)
rep Loc
NoLoc = (FilePath
"", Int
0)
rep (Loc Pos
p Pos
_) = (Pos -> FilePath
posFile Pos
p, Pos -> Int
posCoff Pos
p)
onWarning :: (a, [a], Doc ann) -> Doc AnsiStyle
onWarning (a
loc, [], Doc ann
w) =
forall ann. ann -> Doc ann -> Doc ann
annotate
(Color -> AnsiStyle
color Color
Yellow)
(Doc AnsiStyle
"Warning at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> Text
locText a
loc) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":")
forall ann. Doc ann -> Doc ann -> Doc ann
</> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ann
w)
onWarning (a
loc, [a]
locs, Doc ann
w) =
forall ann. ann -> Doc ann -> Doc ann
annotate
(Color -> AnsiStyle
color Color
Yellow)
(Doc AnsiStyle
"Warning at" forall ann. Doc ann -> Doc ann -> Doc ann
</> forall a ann. Pretty a => a -> Doc ann
pretty (Int -> [Text] -> Text
prettyStacktrace Int
0 (forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a => a -> Text
locText (a
loc forall a. a -> [a] -> [a]
: [a]
locs))))
forall ann. Doc ann -> Doc ann -> Doc ann
</> forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ann
w)
anyWarnings :: Warnings -> Bool
anyWarnings :: Warnings -> Bool
anyWarnings (Warnings [(SrcLoc, [SrcLoc], Doc ())]
ws) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SrcLoc, [SrcLoc], Doc ())]
ws
singleWarning :: SrcLoc -> Doc () -> Warnings
singleWarning :: SrcLoc -> Doc () -> Warnings
singleWarning SrcLoc
loc = SrcLoc -> [SrcLoc] -> Doc () -> Warnings
singleWarning' SrcLoc
loc []
singleWarning' :: SrcLoc -> [SrcLoc] -> Doc () -> Warnings
singleWarning' :: SrcLoc -> [SrcLoc] -> Doc () -> Warnings
singleWarning' SrcLoc
loc [SrcLoc]
locs Doc ()
problem = [(SrcLoc, [SrcLoc], Doc ())] -> Warnings
Warnings [(SrcLoc
loc, [SrcLoc]
locs, Doc ()
problem)]
listWarnings :: Warnings -> [(SrcLoc, Doc ())]
listWarnings :: Warnings -> [(SrcLoc, Doc ())]
listWarnings (Warnings [(SrcLoc, [SrcLoc], Doc ())]
ws) = forall a b. (a -> b) -> [a] -> [b]
map (\(SrcLoc
loc, [SrcLoc]
_, Doc ()
doc) -> (SrcLoc
loc, Doc ()
doc)) [(SrcLoc, [SrcLoc], Doc ())]
ws