{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
-- | Classifying messages by severity and filtering them.
module Language.Haskell.Homplexity.Message (
    Log
  , Message
  , Severity (..)
  , severityOptions
  , critical
  , warn
  , info
  , debug
  , message
  , extract
  ) where

import           Control.Arrow
import           Control.DeepSeq
import           Data.Foldable                      as Foldable
import           Data.Function                      (on)
#if __GLASGOW_HASKELL__ >= 800
import           Data.Semigroup                     (Semigroup (..))
#else
import           Data.Monoid
#endif
import           Data.Sequence                      as Seq
import           HFlags
import           Language.Haskell.Exts              hiding (style)
import           Language.Haskell.TH.Syntax         (Lift (..))
import           GHC.Generics
#ifdef HTML_OUTPUT
import           Prelude                            hiding (div, head, id, span)
import           Text.Blaze.Html4.Strict            hiding (map, style)
import           Text.Blaze.Html4.Strict.Attributes hiding (span, title)
--import           Text.Blaze.Renderer.Utf8           (renderMarkup)
#endif

-- | Keeps a set of messages
newtype Log = Log { Log -> Seq Message
unLog :: Seq Message }
  deriving(Semigroup Log
Log
Semigroup Log
-> Log -> (Log -> Log -> Log) -> ([Log] -> Log) -> Monoid Log
[Log] -> Log
Log -> Log -> Log
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Log
mempty :: Log
$cmappend :: Log -> Log -> Log
mappend :: Log -> Log -> Log
$cmconcat :: [Log] -> Log
mconcat :: [Log] -> Log
Monoid
#if __GLASGOW_HASKELL__ >= 800
          ,NonEmpty Log -> Log
Log -> Log -> Log
(Log -> Log -> Log)
-> (NonEmpty Log -> Log)
-> (forall b. Integral b => b -> Log -> Log)
-> Semigroup Log
forall b. Integral b => b -> Log -> Log
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Log -> Log -> Log
<> :: Log -> Log -> Log
$csconcat :: NonEmpty Log -> Log
sconcat :: NonEmpty Log -> Log
$cstimes :: forall b. Integral b => b -> Log -> Log
stimes :: forall b. Integral b => b -> Log -> Log
Semigroup
#endif
                    )

instance NFData Log where
  rnf :: Log -> ()
rnf = Seq Message -> ()
forall a. NFData a => a -> ()
rnf (Seq Message -> ()) -> (Log -> Seq Message) -> Log -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Log -> Seq Message
unLog

-- | Message from analysis
data Message = Message { Message -> Severity
msgSeverity :: !Severity
                       , Message -> String
msgText     :: !String
                       , Message -> SrcLoc
msgSrc      :: !SrcLoc
                       }
  deriving (Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
/= :: Message -> Message -> Bool
Eq)

instance NFData Message where
  rnf :: Message -> ()
rnf Message {msgSrc :: Message -> SrcLoc
msgSrc=SrcLoc{Int
String
srcFilename :: String
srcLine :: Int
srcColumn :: Int
srcColumn :: SrcLoc -> Int
srcFilename :: SrcLoc -> String
srcLine :: SrcLoc -> Int
..},String
Severity
msgSeverity :: Message -> Severity
msgText :: Message -> String
msgSeverity :: Severity
msgText :: String
..} =
    Severity -> ()
forall a. NFData a => a -> ()
rnf Severity
msgSeverity () -> () -> ()
forall a b. a -> b -> b
`seq` String -> ()
forall a. NFData a => a -> ()
rnf String
msgText () -> () -> ()
forall a b. a -> b -> b
`seq`
    String -> ()
forall a. NFData a => a -> ()
rnf String
srcFilename () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
srcLine () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
srcColumn

instance Show Message where
  showsPrec :: Int -> Message -> ShowS
showsPrec Int
_ Message {msgSrc :: Message -> SrcLoc
msgSrc=loc :: SrcLoc
loc@SrcLoc{Int
String
srcColumn :: SrcLoc -> Int
srcFilename :: SrcLoc -> String
srcLine :: SrcLoc -> Int
srcFilename :: String
srcLine :: Int
srcColumn :: Int
..}, String
Severity
msgSeverity :: Message -> Severity
msgText :: Message -> String
msgSeverity :: Severity
msgText :: String
..} = Severity -> ShowS
forall a. Show a => a -> ShowS
shows Severity
msgSeverity
                                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:)
                                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
srcFilenameString -> ShowS
forall a. [a] -> [a] -> [a]
++)
                                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:)
                                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> ShowS
forall a. Show a => a -> ShowS
shows SrcLoc
loc
                                                  -- . shows srcLine
                                                  -- . shows srcColumn
                                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
": "String -> ShowS
forall a. [a] -> [a] -> [a]
++)
                                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
msgTextString -> ShowS
forall a. [a] -> [a] -> [a]
++)
                                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:)

#ifdef HTML_OUTPUT
instance ToMarkup Message where
  toMarkup Message {msgSrc=SrcLoc{..}, ..} =
    p ! classId $
     (toMarkup msgSeverity
       <> string ": "
       <> (a ! href (toValue srcFilename) $ (string srcFilename))
       <> string ": "
       <> string msgText)
    where
      classId = case msgSeverity of
                     Debug    -> class_ "debug"
                     Info     -> class_ "info"
                     Warning  -> class_ "warning"
                     Critical -> class_ "critical"

instance ToMarkup Severity where
  toMarkup Debug    = span   ! class_ "severity" $ string (show Debug)
  toMarkup Info     = span   ! class_ "severity" $ string (show Info)
  toMarkup Warning  = strong ! class_ "severity" $ string (show Warning)
  toMarkup Critical = strong ! class_ "severity" $ string (show Critical)
#endif

-- | Message severity
data Severity = Debug
              | Info
              | Warning
              | Critical
  deriving (Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
/= :: Severity -> Severity -> Bool
Eq, Eq Severity
Eq Severity
-> (Severity -> Severity -> Ordering)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Severity)
-> (Severity -> Severity -> Severity)
-> Ord Severity
Severity -> Severity -> Bool
Severity -> Severity -> Ordering
Severity -> Severity -> Severity
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 :: Severity -> Severity -> Ordering
compare :: Severity -> Severity -> Ordering
$c< :: Severity -> Severity -> Bool
< :: Severity -> Severity -> Bool
$c<= :: Severity -> Severity -> Bool
<= :: Severity -> Severity -> Bool
$c> :: Severity -> Severity -> Bool
> :: Severity -> Severity -> Bool
$c>= :: Severity -> Severity -> Bool
>= :: Severity -> Severity -> Bool
$cmax :: Severity -> Severity -> Severity
max :: Severity -> Severity -> Severity
$cmin :: Severity -> Severity -> Severity
min :: Severity -> Severity -> Severity
Ord, ReadPrec [Severity]
ReadPrec Severity
Int -> ReadS Severity
ReadS [Severity]
(Int -> ReadS Severity)
-> ReadS [Severity]
-> ReadPrec Severity
-> ReadPrec [Severity]
-> Read Severity
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Severity
readsPrec :: Int -> ReadS Severity
$creadList :: ReadS [Severity]
readList :: ReadS [Severity]
$creadPrec :: ReadPrec Severity
readPrec :: ReadPrec Severity
$creadListPrec :: ReadPrec [Severity]
readListPrec :: ReadPrec [Severity]
Read, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Severity -> ShowS
showsPrec :: Int -> Severity -> ShowS
$cshow :: Severity -> String
show :: Severity -> String
$cshowList :: [Severity] -> ShowS
showList :: [Severity] -> ShowS
Show, Int -> Severity
Severity -> Int
Severity -> [Severity]
Severity -> Severity
Severity -> Severity -> [Severity]
Severity -> Severity -> Severity -> [Severity]
(Severity -> Severity)
-> (Severity -> Severity)
-> (Int -> Severity)
-> (Severity -> Int)
-> (Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> Severity -> [Severity])
-> Enum Severity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Severity -> Severity
succ :: Severity -> Severity
$cpred :: Severity -> Severity
pred :: Severity -> Severity
$ctoEnum :: Int -> Severity
toEnum :: Int -> Severity
$cfromEnum :: Severity -> Int
fromEnum :: Severity -> Int
$cenumFrom :: Severity -> [Severity]
enumFrom :: Severity -> [Severity]
$cenumFromThen :: Severity -> Severity -> [Severity]
enumFromThen :: Severity -> Severity -> [Severity]
$cenumFromTo :: Severity -> Severity -> [Severity]
enumFromTo :: Severity -> Severity -> [Severity]
$cenumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
enumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
Enum, Severity
Severity -> Severity -> Bounded Severity
forall a. a -> a -> Bounded a
$cminBound :: Severity
minBound :: Severity
$cmaxBound :: Severity
maxBound :: Severity
Bounded, (forall x. Severity -> Rep Severity x)
-> (forall x. Rep Severity x -> Severity) -> Generic Severity
forall x. Rep Severity x -> Severity
forall x. Severity -> Rep Severity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Severity -> Rep Severity x
from :: forall x. Severity -> Rep Severity x
$cto :: forall x. Rep Severity x -> Severity
to :: forall x. Rep Severity x -> Severity
Generic, (forall (m :: * -> *). Quote m => Severity -> m Exp)
-> (forall (m :: * -> *). Quote m => Severity -> Code m Severity)
-> Lift Severity
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Severity -> m Exp
forall (m :: * -> *). Quote m => Severity -> Code m Severity
$clift :: forall (m :: * -> *). Quote m => Severity -> m Exp
lift :: forall (m :: * -> *). Quote m => Severity -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Severity -> Code m Severity
liftTyped :: forall (m :: * -> *). Quote m => Severity -> Code m Severity
Lift)

instance NFData Severity where
  rnf :: Severity -> ()
rnf !Severity
_a = ()

-- | String showing all possible values for @Severity@.
severityOptions :: String
severityOptions :: String
severityOptions  = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Severity -> String) -> [Severity] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Severity -> String
forall a. Show a => a -> String
show [Severity
forall a. Bounded a => a
minBound..(Severity
forall a. Bounded a => a
maxBound::Severity)]

instance FlagType Severity where
  defineFlag :: String -> Severity -> String -> Q [Dec]
defineFlag String
n Severity
v = String -> ExpQ -> String -> String -> Q [Dec]
defineEQFlag String
n [| v :: Severity |] String
"{Debug|Info|Warning|Critical}"

-- | Helper for logging a message with given severity.
message ::  Severity -> SrcLoc -> String -> Log
message :: Severity -> SrcLoc -> String -> Log
message Severity
msgSeverity SrcLoc
msgSrc String
msgText = Seq Message -> Log
Log (Seq Message -> Log) -> Seq Message -> Log
forall a b. (a -> b) -> a -> b
$ Message -> Seq Message
forall a. a -> Seq a
Seq.singleton Message {String
SrcLoc
Severity
msgSeverity :: Severity
msgText :: String
msgSrc :: SrcLoc
msgSeverity :: Severity
msgSrc :: SrcLoc
msgText :: String
..}

-- | TODO: automatic inference of the srcLine
-- | Log a certain error
critical :: SrcLoc -> String -> Log
critical :: SrcLoc -> String -> Log
critical  = Severity -> SrcLoc -> String -> Log
message Severity
Critical

-- | Log a warning
warn  ::  SrcLoc -> String -> Log
warn :: SrcLoc -> String -> Log
warn   = Severity -> SrcLoc -> String -> Log
message Severity
Warning

-- | Log informational message
info  ::  SrcLoc -> String -> Log
info :: SrcLoc -> String -> Log
info   = Severity -> SrcLoc -> String -> Log
message Severity
Info

-- | Log debugging message
debug ::  SrcLoc -> String -> Log
debug :: SrcLoc -> String -> Log
debug  = Severity -> SrcLoc -> String -> Log
message Severity
Debug

-- TODO: check if this is not too slow
msgOrdering ::  Message -> Message -> Ordering
msgOrdering :: Message -> Message -> Ordering
msgOrdering = (String, Int) -> (String, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((String, Int) -> (String, Int) -> Ordering)
-> (Message -> (String, Int)) -> Message -> Message -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((SrcLoc -> String
srcFilename (SrcLoc -> String) -> (SrcLoc -> Int) -> SrcLoc -> (String, Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SrcLoc -> Int
srcLine) (SrcLoc -> (String, Int))
-> (Message -> SrcLoc) -> Message -> (String, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> SrcLoc
msgSrc)

-- | Convert @Log@ into ordered sequence (@Seq@).
orderedMessages                  :: Severity -> Log -> Seq Message
orderedMessages :: Severity -> Log -> Seq Message
orderedMessages Severity
severity Log {Seq Message
unLog :: Log -> Seq Message
unLog :: Seq Message
..} = (Message -> Message -> Ordering) -> Seq Message -> Seq Message
forall a. (a -> a -> Ordering) -> Seq a -> Seq a
Seq.unstableSortBy         Message -> Message -> Ordering
msgOrdering  (Seq Message -> Seq Message) -> Seq Message -> Seq Message
forall a b. (a -> b) -> a -> b
$
                                      (Message -> Bool) -> Seq Message -> Seq Message
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter ((Severity
severitySeverity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
<=) (Severity -> Bool) -> (Message -> Severity) -> Message -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Severity
msgSeverity)   Seq Message
unLog

-- | Extract an ordered sequence of messages from the @Log@.
extract ::  Severity -> Log -> [Message]
extract :: Severity -> Log -> [Message]
extract Severity
severity = Seq Message -> [Message]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList
                 (Seq Message -> [Message])
-> (Log -> Seq Message) -> Log -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Severity -> Log -> Seq Message
orderedMessages Severity
severity

instance Show Log where
  showsPrec :: Int -> Log -> ShowS
showsPrec Int
_ Log
l String
e = (Message -> ShowS) -> String -> Seq Message -> String
forall a b. (a -> b -> b) -> b -> Seq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Foldable.foldr  Message -> ShowS
forall a. Show a => a -> ShowS
shows String
e (Seq Message -> String) -> Seq Message -> String
forall a b. (a -> b) -> a -> b
$
                    Severity -> Log -> Seq Message
orderedMessages Severity
Debug Log
l