-- | A very simple representation of collections of warnings.
-- Warnings have a position (so they can be ordered), and their
-- 'Pretty'-instance produces a human-readable string.
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

-- | The warnings produced by the compiler.  The 'Show' instance
-- produces a human-readable description.
newtype Warnings = Warnings [(Loc, [Loc], Doc ())]

instance Semigroup Warnings where
  Warnings [(Loc, [Loc], Doc ())]
ws1 <> :: Warnings -> Warnings -> Warnings
<> Warnings [(Loc, [Loc], Doc ())]
ws2 = [(Loc, [Loc], Doc ())] -> Warnings
Warnings ([(Loc, [Loc], Doc ())] -> Warnings)
-> [(Loc, [Loc], Doc ())] -> Warnings
forall a b. (a -> b) -> a -> b
$ [(Loc, [Loc], Doc ())]
ws1 [(Loc, [Loc], Doc ())]
-> [(Loc, [Loc], Doc ())] -> [(Loc, [Loc], Doc ())]
forall a. Semigroup a => a -> a -> a
<> [(Loc, [Loc], Doc ())]
ws2

instance Monoid Warnings where
  mempty :: Warnings
mempty = [(Loc, [Loc], Doc ())] -> Warnings
Warnings [(Loc, [Loc], Doc ())]
forall a. Monoid a => a
mempty

-- | Prettyprint warnings, making use of colours and such.
prettyWarnings :: Warnings -> Doc AnsiStyle
prettyWarnings :: Warnings -> Doc AnsiStyle
prettyWarnings (Warnings []) = Doc AnsiStyle
forall a. Monoid a => a
mempty
prettyWarnings (Warnings [(Loc, [Loc], Doc ())]
ws) =
  [Doc AnsiStyle] -> Doc AnsiStyle
forall a. [Doc a] -> Doc a
stack ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ ((Loc, [Loc], Doc ()) -> Doc AnsiStyle)
-> [(Loc, [Loc], Doc ())] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline) (Doc AnsiStyle -> Doc AnsiStyle)
-> ((Loc, [Loc], Doc ()) -> Doc AnsiStyle)
-> (Loc, [Loc], Doc ())
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc, [Loc], Doc ()) -> Doc AnsiStyle
forall {a} {ann}. Located a => (a, [a], Doc ann) -> Doc AnsiStyle
onWarning) ([(Loc, [Loc], Doc ())] -> [Doc AnsiStyle])
-> [(Loc, [Loc], Doc ())] -> [Doc AnsiStyle]
forall a b. (a -> b) -> a -> b
$ ((Loc, [Loc], Doc ()) -> (FilePath, Int))
-> [(Loc, [Loc], Doc ())] -> [(Loc, [Loc], Doc ())]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Loc -> (FilePath, Int)
rep (Loc -> (FilePath, Int))
-> ((Loc, [Loc], Doc ()) -> Loc)
-> (Loc, [Loc], Doc ())
-> (FilePath, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc, [Loc], Doc ()) -> Loc
forall {a} {b} {c}. Located a => (a, b, c) -> Loc
wloc) [(Loc, [Loc], Doc ())]
ws
  where
    wloc :: (a, b, c) -> Loc
wloc (a
x, b
_, c
_) = a -> Loc
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) =
      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate
        (Color -> AnsiStyle
color Color
Yellow)
        (Doc AnsiStyle
"Warning at" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Text
forall a. Located a => a -> Text
locText a
loc) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":")
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
</> Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ann
w)
    onWarning (a
loc, [a]
locs, Doc ann
w) =
      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate
        (Color -> AnsiStyle
color Color
Yellow)
        (Doc AnsiStyle
"Warning at" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
</> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> [Text] -> Text
prettyStacktrace Int
0 ((a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
forall a. Located a => a -> Text
locText (a
loc a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
locs))))
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
</> Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ann
w)

-- | True if there are any warnings in the set.
anyWarnings :: Warnings -> Bool
anyWarnings :: Warnings -> Bool
anyWarnings (Warnings [(Loc, [Loc], Doc ())]
ws) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Loc, [Loc], Doc ())] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Loc, [Loc], Doc ())]
ws

-- | A single warning at the given location.
singleWarning :: Loc -> Doc () -> Warnings
singleWarning :: Loc -> Doc () -> Warnings
singleWarning Loc
loc = Loc -> [Loc] -> Doc () -> Warnings
singleWarning' Loc
loc []

-- | A single warning at the given location, but also with a stack
-- trace (sort of) to the location.
singleWarning' :: Loc -> [Loc] -> Doc () -> Warnings
singleWarning' :: Loc -> [Loc] -> Doc () -> Warnings
singleWarning' Loc
loc [Loc]
locs Doc ()
problem = [(Loc, [Loc], Doc ())] -> Warnings
Warnings [(Loc
loc, [Loc]
locs, Doc ()
problem)]

-- | Exports Warnings into a list of (location, problem).
listWarnings :: Warnings -> [(Loc, Doc ())]
listWarnings :: Warnings -> [(Loc, Doc ())]
listWarnings (Warnings [(Loc, [Loc], Doc ())]
ws) = ((Loc, [Loc], Doc ()) -> (Loc, Doc ()))
-> [(Loc, [Loc], Doc ())] -> [(Loc, Doc ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(Loc
loc, [Loc]
_, Doc ()
doc) -> (Loc
loc, Doc ()
doc)) [(Loc, [Loc], Doc ())]
ws