Result.hs

{-# LANGUAGE DeriveDataTypeable #-}
{- |
Module      :  ./Common/Result.hs
Description :  Result monad for accumulating Diagnosis messages
Copyright   :  (c) T. Mossakowski, C. Maeder, Uni Bremen 2002-2008
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

'Result' monad for accumulating 'Diagnosis' messages
               during analysis phases.
-}

module Common.Result
  ( DiagKind (..)
  , Diagnosis (..)
  , mkDiag
  , mkNiceDiag
  , isErrorDiag
  , hasErrors
  , addErrorDiag
  , checkUniqueness
  , Result (..)
  , appendDiags
  , joinResultWith
  , joinResult
  , mapR
  , fatal_error
  , mkError
  , debug
  , plain_error
  , warning
  , justWarn
  , hint
  , justHint
  , message
  , maybeToResult
  , resultToMonad
  , resultToMaybe
  , adjustPos
  , updDiagKind
  , propagateErrors
  , showErr
  , prettyRange
  , filterDiags
  , showRelDiags
  , printDiags
  ) where

import Common.Doc as Doc
import Common.DocUtils
import Common.GlobalAnnotations
import Common.Id
import Common.Lexer

import Control.Applicative
import Control.Monad.Identity
import qualified Control.Monad.Fail as Fail

import Data.Data
import Data.Function
import Data.List

import Text.ParserCombinators.Parsec.Error
import Text.ParserCombinators.Parsec.Char (char)
import Text.ParserCombinators.Parsec (parse)

-- | severness of diagnostic messages
data DiagKind = Error | Warning | Hint | Debug
              | MessageW -- ^ used for messages in the web interface
                deriving (Show, Eq, Ord, Typeable, Data)

-- | a diagnostic message with 'Pos'
data Diagnosis = Diag { diagKind :: DiagKind
                      , diagString :: String
                      , diagPos :: Range
                      } deriving (Eq, Typeable, Data)

-- | construct a message for a printable item that carries a position
mkDiag :: (GetRange a,
 Pretty a) => DiagKind -> String -> a -> Diagnosis
mkDiag k s a = let q = text "'" in
    Diag k (show $ sep [text s, q <> pretty a <> q]) $ getRangeSpan a

-- | construct a message for a printable item that carries a position
mkNiceDiag :: (GetRange a, Pretty a) => GlobalAnnos
       -> DiagKind -> String -> a -> Diagnosis
mkNiceDiag ga k s a = let q = text "'" in
    Diag k (renderText ga $ sep [text s, q <> pretty a <> q])
      $ getRangeSpan a

-- | check whether a diagnosis is an error
isErrorDiag :: Diagnosis -> Bool
isErrorDiag d = case diagKind d of
                Error -> True
                _ -> False

-- | Check whether a diagnosis list contains errors
hasErrors :: [Diagnosis] -> Bool
hasErrors = any isErrorDiag

-- | add a further error message to explain a failure
addErrorDiag :: (GetRange a, Pretty a) => String -> a -> Result b -> Result b
addErrorDiag str a r@(Result ds ms) = if hasErrors ds then
  Result (mkDiag Error str a : ds) ms else r

-- | add range to a diagnosis
adjustDiagPos :: Range -> Diagnosis -> Diagnosis
adjustDiagPos r d = if isNullRange $ diagPos d then d { diagPos = r } else d

-- | change the diag kind of a diagnosis
updDiagKind :: (DiagKind -> DiagKind) -> Diagnosis -> Diagnosis
updDiagKind f d = d { diagKind = f $ diagKind d }

-- | A uniqueness check yields errors for duplicates in a given list.
checkUniqueness :: (Pretty a, GetRange a, Ord a) => [a] -> [Diagnosis]
checkUniqueness l =
    let vd = filter ( not . null . tail) $ group $ sort l
    in map (\ vs -> mkDiag Error ("duplicates at '" ++
                                  showSepList (showString " ") shortPosShow
                                  (concatMap getPosList (tail vs)) "'"
                                   ++ " for") (head vs)) vd
    where shortPosShow :: Pos -> ShowS
          shortPosShow p = showParen True
                           (shows (sourceLine p) .
                            showString "," .
                            shows (sourceColumn p))

-- | The result monad. A failing result should include an error message.
data Result a = Result { diags :: [Diagnosis]
                       , maybeResult :: Maybe a
                       } deriving (Show, Typeable, Data)

instance Functor Result where
    fmap f (Result errs m) = Result errs $ fmap f m

instance Applicative Result where
    pure = return
    (<*>) = ap

instance Monad Result where
  return = Result [] . Just
  r@(Result e m) >>= f = case m of
      Nothing -> Result e Nothing
      Just x -> joinResult r $ f x

instance Alternative Result where
    (<|>) = mplus
    empty = mzero

instance MonadPlus Result where
   mzero = Result [] Nothing
   r1@(Result _ m) `mplus` r2 = case m of
                                 Nothing -> r2
                                 Just _ -> r1

instance Fail.MonadFail Result where
  fail s = fatal_error s nullRange

instance Fail.MonadFail Identity where
  fail = Fail.fail . show

appendDiags :: [Diagnosis] -> Result ()
appendDiags ds = Result ds (Just ())

-- | join two results with a combining function
joinResultWith :: (a -> b -> c) -> Result a -> Result b -> Result c
joinResultWith f (Result d1 m1) (Result d2 m2) = Result (d1 ++ d2) $
    do r1 <- m1
       r2 <- m2
       return $ f r1 r2

-- | join two results
joinResult :: Result a -> Result b -> Result b
joinResult = joinResultWith (\ _ b -> b)

-- | join a list of results that are independently computed
mapR :: (a -> Result b) -> [a] -> Result [b]
mapR ana = foldr (joinResultWith (:) . ana) $ Result [] $ Just []

-- | a failing result with a proper position
fatal_error :: String -> Range -> Result a
fatal_error s p = Result [Diag Error s p] Nothing

-- | a failing result constructing a message from a type
mkError :: (GetRange a, Pretty a) => String -> a -> Result b
mkError s c = Result [mkDiag Error s c] Nothing

-- | add a debug point
debug :: (GetRange a, Pretty a) => Int -> (String, a) -> Result ()
debug n (s, a) = Result
  [mkDiag Debug (unlines [" point " ++ show n, "Variable " ++ s ++ ":"]) a ]
  $ Just ()

-- | add an error message but don't fail
plain_error :: a -> String -> Range -> Result a
plain_error x s p = Result [Diag Error s p] $ Just x

-- | add a warning
warning :: a -> String -> Range -> Result a
warning x s p = Result [Diag Warning s p] $ Just x

-- | just add a warning without position information
justWarn :: a -> String -> Result a
justWarn x s = warning x s nullRange

-- | add a hint
hint :: a -> String -> Range -> Result a
hint x s p = Result [Diag Hint s p] $ Just x

-- | just add a hint without position information
justHint :: a -> String -> Result a
justHint x s = hint x s nullRange

-- | add a (web interface) message
message :: a -> String -> Result a
message x m = Result [Diag MessageW m nullRange] $ Just x

-- | add a failure message to 'Nothing'
maybeToResult :: Range -> String -> Maybe a -> Result a
maybeToResult p s m = Result (case m of
                              Nothing -> [Diag Error s p]
                              Just _ -> []) m

-- | check whether no errors are present, coerce into 'Maybe'
resultToMaybe :: Result a -> Maybe a
resultToMaybe = resultToMonad ""

-- | adjust positions of diagnoses
adjustPos :: Range -> Result a -> Result a
adjustPos p r =
  r {diags = map (adjustDiagPos p) $ diags r}

-- | Propagate errors using the error function
resultToMonad :: Fail.MonadFail m => String -> Result a -> m a
resultToMonad pos r = let ds = diags r in
  case (hasErrors ds, maybeResult r) of
    (False, Just x) -> return x
    _ -> Fail.fail $ pos ++ ' ' : showRelDiags 2 ds

-- | Propagate errors using the error function
propagateErrors :: String -> Result a -> a
propagateErrors pos = runIdentity . resultToMonad pos

-- | showing (Parsec) parse errors using our own 'showPos' function
showErr :: ParseError -> String
showErr err = let
    (lookAheads, msgs) = partition (\ m -> case m of
                     Message str -> isPrefixOf lookaheadPosition str
                     _ -> False) $ errorMessages err
    readPos :: String -> Maybe Pos
    readPos s = case parse (do
            ls <- getNumber
            char '.'
            cs <- getNumber
            return $ newPos "" (value 10 ls) (value 10 cs)) "" s of
                  Left _ -> Nothing
                  Right x -> Just x
    pos = fromSourcePos (errorPos err)
    poss = pos : foldr (\ s l -> case readPos $
                                 drop (length lookaheadPosition)
                                 $ messageString s of
                        Just p -> p {sourceName = sourceName pos} : l
                        _ -> l) [] lookAheads
    in shows (prettySingleSourceRange poss) ":" ++
       showErrorMessages "or" "unknown parse error"
           "expecting" "unexpected" "end of input" msgs

prettySingleSourceRange :: [Pos] -> Doc
prettySingleSourceRange sp = let
    mi = minimum sp
    ma = maximum sp
    in case compare mi ma of
          EQ -> text (showPos ma "")
          _ -> text $ showPos mi "-"
               ++ showPos ma {sourceName = ""} ""

prettyRange :: [Pos] -> Doc
prettyRange = sepByCommas . map prettySingleSourceRange
    . groupBy (on (==) sourceName) . sort

instance Pretty Range where
    pretty = prettyRange . rangeToList

relevantDiagKind :: Int -> DiagKind -> Bool
relevantDiagKind v k = case k of
    Error -> True
    Warning -> v >= 2
    Hint -> v >= 4
    Debug -> v >= 5
    MessageW -> False

filterDiags :: Int -> [Diagnosis] -> [Diagnosis]
filterDiags v = filter $ relevantDiagKind v . diagKind

showRelDiags :: Int -> [Diagnosis] -> String
showRelDiags v = unlines . map show . filterDiags v

printDiags :: Int -> [Diagnosis] -> IO ()
printDiags v = putStr . showRelDiags v

instance Show Diagnosis where
    showsPrec _ = shows . pretty

instance Pretty Diagnosis where
    pretty (Diag k s (Range sp)) = sep
        [ sep [case sp of
            [] -> Doc.empty
            _ -> prettyRange sp <> colon
        , case k of
            MessageW -> Doc.empty
            _ -> text (case k of
                  Error -> "***"
                  _ -> "###") <+> text (show k) <> colon
        ]
      , text s]

instance GetRange Diagnosis where
    getRange = diagPos

instance Pretty a => Pretty (Result a) where
    pretty (Result ds m) = vcat $ pretty m : map pretty ds