{-# 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 (Int -> DiagKind -> ShowS
[DiagKind] -> ShowS
DiagKind -> String
(Int -> DiagKind -> ShowS)
-> (DiagKind -> String) -> ([DiagKind] -> ShowS) -> Show DiagKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiagKind] -> ShowS
$cshowList :: [DiagKind] -> ShowS
show :: DiagKind -> String
$cshow :: DiagKind -> String
showsPrec :: Int -> DiagKind -> ShowS
$cshowsPrec :: Int -> DiagKind -> ShowS
Show, DiagKind -> DiagKind -> Bool
(DiagKind -> DiagKind -> Bool)
-> (DiagKind -> DiagKind -> Bool) -> Eq DiagKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DiagKind -> DiagKind -> Bool
$c/= :: DiagKind -> DiagKind -> Bool
== :: DiagKind -> DiagKind -> Bool
$c== :: DiagKind -> DiagKind -> Bool
Eq, Eq DiagKind
Eq DiagKind =>
(DiagKind -> DiagKind -> Ordering)
-> (DiagKind -> DiagKind -> Bool)
-> (DiagKind -> DiagKind -> Bool)
-> (DiagKind -> DiagKind -> Bool)
-> (DiagKind -> DiagKind -> Bool)
-> (DiagKind -> DiagKind -> DiagKind)
-> (DiagKind -> DiagKind -> DiagKind)
-> Ord DiagKind
DiagKind -> DiagKind -> Bool
DiagKind -> DiagKind -> Ordering
DiagKind -> DiagKind -> DiagKind
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
min :: DiagKind -> DiagKind -> DiagKind
$cmin :: DiagKind -> DiagKind -> DiagKind
max :: DiagKind -> DiagKind -> DiagKind
$cmax :: DiagKind -> DiagKind -> DiagKind
>= :: DiagKind -> DiagKind -> Bool
$c>= :: DiagKind -> DiagKind -> Bool
> :: DiagKind -> DiagKind -> Bool
$c> :: DiagKind -> DiagKind -> Bool
<= :: DiagKind -> DiagKind -> Bool
$c<= :: DiagKind -> DiagKind -> Bool
< :: DiagKind -> DiagKind -> Bool
$c< :: DiagKind -> DiagKind -> Bool
compare :: DiagKind -> DiagKind -> Ordering
$ccompare :: DiagKind -> DiagKind -> Ordering
$cp1Ord :: Eq DiagKind
Ord, Typeable, Typeable DiagKind
Constr
DataType
Typeable DiagKind =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DiagKind -> c DiagKind)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DiagKind)
-> (DiagKind -> Constr)
-> (DiagKind -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DiagKind))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DiagKind))
-> ((forall b. Data b => b -> b) -> DiagKind -> DiagKind)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagKind -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagKind -> r)
-> (forall u. (forall d. Data d => d -> u) -> DiagKind -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DiagKind -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DiagKind -> m DiagKind)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DiagKind -> m DiagKind)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DiagKind -> m DiagKind)
-> Data DiagKind
DiagKind -> Constr
DiagKind -> DataType
(forall b. Data b => b -> b) -> DiagKind -> DiagKind
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagKind -> c DiagKind
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagKind
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DiagKind -> u
forall u. (forall d. Data d => d -> u) -> DiagKind -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagKind -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagKind -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagKind
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagKind -> c DiagKind
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagKind)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DiagKind)
$cMessageW :: Constr
$cDebug :: Constr
$cHint :: Constr
$cWarning :: Constr
$cError :: Constr
$tDiagKind :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
gmapMp :: (forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
gmapM :: (forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DiagKind -> m DiagKind
gmapQi :: Int -> (forall d. Data d => d -> u) -> DiagKind -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DiagKind -> u
gmapQ :: (forall d. Data d => d -> u) -> DiagKind -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagKind -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagKind -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagKind -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagKind -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagKind -> r
gmapT :: (forall b. Data b => b -> b) -> DiagKind -> DiagKind
$cgmapT :: (forall b. Data b => b -> b) -> DiagKind -> DiagKind
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DiagKind)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DiagKind)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DiagKind)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagKind)
dataTypeOf :: DiagKind -> DataType
$cdataTypeOf :: DiagKind -> DataType
toConstr :: DiagKind -> Constr
$ctoConstr :: DiagKind -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagKind
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagKind
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagKind -> c DiagKind
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagKind -> c DiagKind
$cp1Data :: Typeable DiagKind
Data)

-- | a diagnostic message with 'Pos'
data Diagnosis = Diag { Diagnosis -> DiagKind
diagKind :: DiagKind
                      , Diagnosis -> String
diagString :: String
                      , Diagnosis -> Range
diagPos :: Range
                      } deriving (Diagnosis -> Diagnosis -> Bool
(Diagnosis -> Diagnosis -> Bool)
-> (Diagnosis -> Diagnosis -> Bool) -> Eq Diagnosis
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Diagnosis -> Diagnosis -> Bool
$c/= :: Diagnosis -> Diagnosis -> Bool
== :: Diagnosis -> Diagnosis -> Bool
$c== :: Diagnosis -> Diagnosis -> Bool
Eq, Typeable, Typeable Diagnosis
Constr
DataType
Typeable Diagnosis =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Diagnosis -> c Diagnosis)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Diagnosis)
-> (Diagnosis -> Constr)
-> (Diagnosis -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Diagnosis))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Diagnosis))
-> ((forall b. Data b => b -> b) -> Diagnosis -> Diagnosis)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Diagnosis -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Diagnosis -> r)
-> (forall u. (forall d. Data d => d -> u) -> Diagnosis -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Diagnosis -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis)
-> Data Diagnosis
Diagnosis -> Constr
Diagnosis -> DataType
(forall b. Data b => b -> b) -> Diagnosis -> Diagnosis
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Diagnosis -> c Diagnosis
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Diagnosis
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Diagnosis -> u
forall u. (forall d. Data d => d -> u) -> Diagnosis -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Diagnosis -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Diagnosis -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Diagnosis
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Diagnosis -> c Diagnosis
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Diagnosis)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Diagnosis)
$cDiag :: Constr
$tDiagnosis :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
gmapMp :: (forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
gmapM :: (forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Diagnosis -> m Diagnosis
gmapQi :: Int -> (forall d. Data d => d -> u) -> Diagnosis -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Diagnosis -> u
gmapQ :: (forall d. Data d => d -> u) -> Diagnosis -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Diagnosis -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Diagnosis -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Diagnosis -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Diagnosis -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Diagnosis -> r
gmapT :: (forall b. Data b => b -> b) -> Diagnosis -> Diagnosis
$cgmapT :: (forall b. Data b => b -> b) -> Diagnosis -> Diagnosis
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Diagnosis)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Diagnosis)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Diagnosis)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Diagnosis)
dataTypeOf :: Diagnosis -> DataType
$cdataTypeOf :: Diagnosis -> DataType
toConstr :: Diagnosis -> Constr
$ctoConstr :: Diagnosis -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Diagnosis
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Diagnosis
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Diagnosis -> c Diagnosis
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Diagnosis -> c Diagnosis
$cp1Data :: Typeable Diagnosis
Data)

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

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

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

-- | Check whether a diagnosis list contains errors
hasErrors :: [Diagnosis] -> Bool
hasErrors :: [Diagnosis] -> Bool
hasErrors = (Diagnosis -> Bool) -> [Diagnosis] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Diagnosis -> Bool
isErrorDiag

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

-- | add range to a diagnosis
adjustDiagPos :: Range -> Diagnosis -> Diagnosis
adjustDiagPos :: Range -> Diagnosis -> Diagnosis
adjustDiagPos r :: Range
r d :: Diagnosis
d = if Range -> Bool
isNullRange (Range -> Bool) -> Range -> Bool
forall a b. (a -> b) -> a -> b
$ Diagnosis -> Range
diagPos Diagnosis
d then Diagnosis
d { diagPos :: Range
diagPos = Range
r } else Diagnosis
d

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

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

-- | The result monad. A failing result should include an error message.
data Result a = Result { Result a -> [Diagnosis]
diags :: [Diagnosis]
                       , Result a -> Maybe a
maybeResult :: Maybe a
                       } deriving (Int -> Result a -> ShowS
[Result a] -> ShowS
Result a -> String
(Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show, Typeable, Typeable (Result a)
Constr
DataType
Typeable (Result a) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Result a -> c (Result a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Result a))
-> (Result a -> Constr)
-> (Result a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Result a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Result a)))
-> ((forall b. Data b => b -> b) -> Result a -> Result a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Result a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Result a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Result a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Result a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Result a -> m (Result a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Result a -> m (Result a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Result a -> m (Result a))
-> Data (Result a)
Result a -> Constr
Result a -> DataType
(forall d. Data d => c (t d)) -> Maybe (c (Result a))
(forall b. Data b => b -> b) -> Result a -> Result a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Result a -> c (Result a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Result a)
forall a. Data a => Typeable (Result a)
forall a. Data a => Result a -> Constr
forall a. Data a => Result a -> DataType
forall a.
Data a =>
(forall b. Data b => b -> b) -> Result a -> Result a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Result a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> Result a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Result a -> m (Result a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Result a -> m (Result a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Result a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Result a -> c (Result a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Result a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Result a))
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Result a -> u
forall u. (forall d. Data d => d -> u) -> Result a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Result a -> m (Result a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Result a -> m (Result a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Result a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Result a -> c (Result a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Result a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Result a))
$cResult :: Constr
$tResult :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Result a -> m (Result a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Result a -> m (Result a)
gmapMp :: (forall d. Data d => d -> m d) -> Result a -> m (Result a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Result a -> m (Result a)
gmapM :: (forall d. Data d => d -> m d) -> Result a -> m (Result a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Result a -> m (Result a)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Result a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Result a -> u
gmapQ :: (forall d. Data d => d -> u) -> Result a -> [u]
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Result a -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Result a -> r
gmapT :: (forall b. Data b => b -> b) -> Result a -> Result a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Result a -> Result a
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Result a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Result a))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Result a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Result a))
dataTypeOf :: Result a -> DataType
$cdataTypeOf :: forall a. Data a => Result a -> DataType
toConstr :: Result a -> Constr
$ctoConstr :: forall a. Data a => Result a -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Result a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Result a)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Result a -> c (Result a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Result a -> c (Result a)
$cp1Data :: forall a. Data a => Typeable (Result a)
Data)

instance Functor Result where
    fmap :: (a -> b) -> Result a -> Result b
fmap f :: a -> b
f (Result errs :: [Diagnosis]
errs m :: Maybe a
m) = [Diagnosis] -> Maybe b -> Result b
forall a. [Diagnosis] -> Maybe a -> Result a
Result [Diagnosis]
errs (Maybe b -> Result b) -> Maybe b -> Result b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
m

instance Applicative Result where
    pure :: a -> Result a
pure = a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: Result (a -> b) -> Result a -> Result b
(<*>) = Result (a -> b) -> Result a -> Result b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Result where
  return :: a -> Result a
return = [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [] (Maybe a -> Result a) -> (a -> Maybe a) -> a -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just
  r :: Result a
r@(Result e :: [Diagnosis]
e m :: Maybe a
m) >>= :: Result a -> (a -> Result b) -> Result b
>>= f :: a -> Result b
f = case Maybe a
m of
      Nothing -> [Diagnosis] -> Maybe b -> Result b
forall a. [Diagnosis] -> Maybe a -> Result a
Result [Diagnosis]
e Maybe b
forall a. Maybe a
Nothing
      Just x :: a
x -> Result a -> Result b -> Result b
forall a b. Result a -> Result b -> Result b
joinResult Result a
r (Result b -> Result b) -> Result b -> Result b
forall a b. (a -> b) -> a -> b
$ a -> Result b
f a
x

instance Alternative Result where
    <|> :: Result a -> Result a -> Result a
(<|>) = Result a -> Result a -> Result a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
    empty :: Result a
empty = Result a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance MonadPlus Result where
   mzero :: Result a
mzero = [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [] Maybe a
forall a. Maybe a
Nothing
   r1 :: Result a
r1@(Result _ m :: Maybe a
m) mplus :: Result a -> Result a -> Result a
`mplus` r2 :: Result a
r2 = case Maybe a
m of
                                 Nothing -> Result a
r2
                                 Just _ -> Result a
r1

instance Fail.MonadFail Result where
  fail :: String -> Result a
fail s :: String
s = String -> Range -> Result a
forall a. String -> Range -> Result a
fatal_error String
s Range
nullRange

instance Fail.MonadFail Identity where
  fail :: String -> Identity a
fail = String -> Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> Identity a) -> ShowS -> String -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. Show a => a -> String
show

appendDiags :: [Diagnosis] -> Result ()
appendDiags :: [Diagnosis] -> Result ()
appendDiags ds :: [Diagnosis]
ds = [Diagnosis] -> Maybe () -> Result ()
forall a. [Diagnosis] -> Maybe a -> Result a
Result [Diagnosis]
ds (() -> Maybe ()
forall a. a -> Maybe a
Just ())

-- | join two results with a combining function
joinResultWith :: (a -> b -> c) -> Result a -> Result b -> Result c
joinResultWith :: (a -> b -> c) -> Result a -> Result b -> Result c
joinResultWith f :: a -> b -> c
f (Result d1 :: [Diagnosis]
d1 m1 :: Maybe a
m1) (Result d2 :: [Diagnosis]
d2 m2 :: Maybe b
m2) = [Diagnosis] -> Maybe c -> Result c
forall a. [Diagnosis] -> Maybe a -> Result a
Result ([Diagnosis]
d1 [Diagnosis] -> [Diagnosis] -> [Diagnosis]
forall a. [a] -> [a] -> [a]
++ [Diagnosis]
d2) (Maybe c -> Result c) -> Maybe c -> Result c
forall a b. (a -> b) -> a -> b
$
    do a
r1 <- Maybe a
m1
       b
r2 <- Maybe b
m2
       c -> Maybe c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> Maybe c) -> c -> Maybe c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
f a
r1 b
r2

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

-- | join a list of results that are independently computed
mapR :: (a -> Result b) -> [a] -> Result [b]
mapR :: (a -> Result b) -> [a] -> Result [b]
mapR ana :: a -> Result b
ana = (a -> Result [b] -> Result [b]) -> Result [b] -> [a] -> Result [b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((b -> [b] -> [b]) -> Result b -> Result [b] -> Result [b]
forall a b c. (a -> b -> c) -> Result a -> Result b -> Result c
joinResultWith (:) (Result b -> Result [b] -> Result [b])
-> (a -> Result b) -> a -> Result [b] -> Result [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result b
ana) (Result [b] -> [a] -> Result [b])
-> Result [b] -> [a] -> Result [b]
forall a b. (a -> b) -> a -> b
$ [Diagnosis] -> Maybe [b] -> Result [b]
forall a. [Diagnosis] -> Maybe a -> Result a
Result [] (Maybe [b] -> Result [b]) -> Maybe [b] -> Result [b]
forall a b. (a -> b) -> a -> b
$ [b] -> Maybe [b]
forall a. a -> Maybe a
Just []

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

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

-- | add a debug point
debug :: (GetRange a, Pretty a) => Int -> (String, a) -> Result ()
debug :: Int -> (String, a) -> Result ()
debug n :: Int
n (s :: String
s, a :: a
a) = [Diagnosis] -> Maybe () -> Result ()
forall a. [Diagnosis] -> Maybe a -> Result a
Result
  [DiagKind -> String -> a -> Diagnosis
forall a.
(GetRange a, Pretty a) =>
DiagKind -> String -> a -> Diagnosis
mkDiag DiagKind
Debug ([String] -> String
unlines [" point " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n, "Variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":"]) a
a ]
  (Maybe () -> Result ()) -> Maybe () -> Result ()
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ()

-- | add an error message but don't fail
plain_error :: a -> String -> Range -> Result a
plain_error :: a -> String -> Range -> Result a
plain_error x :: a
x s :: String
s p :: Range
p = [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Range -> Diagnosis
Diag DiagKind
Error String
s Range
p] (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x

-- | add a warning
warning :: a -> String -> Range -> Result a
warning :: a -> String -> Range -> Result a
warning x :: a
x s :: String
s p :: Range
p = [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Range -> Diagnosis
Diag DiagKind
Warning String
s Range
p] (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x

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

-- | add a hint
hint :: a -> String -> Range -> Result a
hint :: a -> String -> Range -> Result a
hint x :: a
x s :: String
s p :: Range
p = [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Range -> Diagnosis
Diag DiagKind
Hint String
s Range
p] (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x

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

-- | add a (web interface) message
message :: a -> String -> Result a
message :: a -> String -> Result a
message x :: a
x m :: String
m = [Diagnosis] -> Maybe a -> Result a
forall a. [Diagnosis] -> Maybe a -> Result a
Result [DiagKind -> String -> Range -> Diagnosis
Diag DiagKind
MessageW String
m Range
nullRange] (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x

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

-- | check whether no errors are present, coerce into 'Maybe'
resultToMaybe :: Result a -> Maybe a
resultToMaybe :: Result a -> Maybe a
resultToMaybe = String -> Result a -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> Result a -> m a
resultToMonad ""

-- | adjust positions of diagnoses
adjustPos :: Range -> Result a -> Result a
adjustPos :: Range -> Result a -> Result a
adjustPos p :: Range
p r :: Result a
r =
  Result a
r {diags :: [Diagnosis]
diags = (Diagnosis -> Diagnosis) -> [Diagnosis] -> [Diagnosis]
forall a b. (a -> b) -> [a] -> [b]
map (Range -> Diagnosis -> Diagnosis
adjustDiagPos Range
p) ([Diagnosis] -> [Diagnosis]) -> [Diagnosis] -> [Diagnosis]
forall a b. (a -> b) -> a -> b
$ Result a -> [Diagnosis]
forall a. Result a -> [Diagnosis]
diags Result a
r}

-- | Propagate errors using the error function
resultToMonad :: Fail.MonadFail m => String -> Result a -> m a
resultToMonad :: String -> Result a -> m a
resultToMonad pos :: String
pos r :: Result a
r = let ds :: [Diagnosis]
ds = Result a -> [Diagnosis]
forall a. Result a -> [Diagnosis]
diags Result a
r in
  case ([Diagnosis] -> Bool
hasErrors [Diagnosis]
ds, Result a -> Maybe a
forall a. Result a -> Maybe a
maybeResult Result a
r) of
    (False, Just x :: a
x) -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    _ -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ ' ' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> [Diagnosis] -> String
showRelDiags 2 [Diagnosis]
ds

-- | Propagate errors using the error function
propagateErrors :: String -> Result a -> a
propagateErrors :: String -> Result a -> a
propagateErrors pos :: String
pos = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (Result a -> Identity a) -> Result a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Result a -> Identity a
forall (m :: * -> *) a. MonadFail m => String -> Result a -> m a
resultToMonad String
pos

-- | showing (Parsec) parse errors using our own 'showPos' function
showErr :: ParseError -> String
showErr :: ParseError -> String
showErr err :: ParseError
err = let
    (lookAheads :: [Message]
lookAheads, msgs :: [Message]
msgs) = (Message -> Bool) -> [Message] -> ([Message], [Message])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ m :: Message
m -> case Message
m of
                     Message str :: String
str -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
lookaheadPosition String
str
                     _ -> Bool
False) ([Message] -> ([Message], [Message]))
-> [Message] -> ([Message], [Message])
forall a b. (a -> b) -> a -> b
$ ParseError -> [Message]
errorMessages ParseError
err
    readPos :: String -> Maybe Pos
    readPos :: String -> Maybe Pos
readPos s :: String
s = case Parsec String () Pos -> String -> String -> Either ParseError Pos
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (do
            String
ls <- CharParser () String
forall st. CharParser st String
getNumber
            Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '.'
            String
cs <- CharParser () String
forall st. CharParser st String
getNumber
            Pos -> Parsec String () Pos
forall (m :: * -> *) a. Monad m => a -> m a
return (Pos -> Parsec String () Pos) -> Pos -> Parsec String () Pos
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Pos
newPos "" (Int -> String -> Int
value 10 String
ls) (Int -> String -> Int
value 10 String
cs)) "" String
s of
                  Left _ -> Maybe Pos
forall a. Maybe a
Nothing
                  Right x :: Pos
x -> Pos -> Maybe Pos
forall a. a -> Maybe a
Just Pos
x
    pos :: Pos
pos = SourcePos -> Pos
fromSourcePos (ParseError -> SourcePos
errorPos ParseError
err)
    poss :: [Pos]
poss = Pos
pos Pos -> [Pos] -> [Pos]
forall a. a -> [a] -> [a]
: (Message -> [Pos] -> [Pos]) -> [Pos] -> [Message] -> [Pos]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ s :: Message
s l :: [Pos]
l -> case String -> Maybe Pos
readPos (String -> Maybe Pos) -> String -> Maybe Pos
forall a b. (a -> b) -> a -> b
$
                                 Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
lookaheadPosition)
                                 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Message -> String
messageString Message
s of
                        Just p :: Pos
p -> Pos
p {sourceName :: String
sourceName = Pos -> String
sourceName Pos
pos} Pos -> [Pos] -> [Pos]
forall a. a -> [a] -> [a]
: [Pos]
l
                        _ -> [Pos]
l) [] [Message]
lookAheads
    in Doc -> ShowS
forall a. Show a => a -> ShowS
shows ([Pos] -> Doc
prettySingleSourceRange [Pos]
poss) ":" String -> ShowS
forall a. [a] -> [a] -> [a]
++
       String
-> String -> String -> String -> String -> [Message] -> String
showErrorMessages "or" "unknown parse error"
           "expecting" "unexpected" "end of input" [Message]
msgs

prettySingleSourceRange :: [Pos] -> Doc
prettySingleSourceRange :: [Pos] -> Doc
prettySingleSourceRange sp :: [Pos]
sp = let
    mi :: Pos
mi = [Pos] -> Pos
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Pos]
sp
    ma :: Pos
ma = [Pos] -> Pos
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Pos]
sp
    in case Pos -> Pos -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Pos
mi Pos
ma of
          EQ -> String -> Doc
text (Pos -> ShowS
showPos Pos
ma "")
          _ -> String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Pos -> ShowS
showPos Pos
mi "-"
               String -> ShowS
forall a. [a] -> [a] -> [a]
++ Pos -> ShowS
showPos Pos
ma {sourceName :: String
sourceName = ""} ""

prettyRange :: [Pos] -> Doc
prettyRange :: [Pos] -> Doc
prettyRange = [Doc] -> Doc
sepByCommas ([Doc] -> Doc) -> ([Pos] -> [Doc]) -> [Pos] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Pos] -> Doc) -> [[Pos]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Pos] -> Doc
prettySingleSourceRange
    ([[Pos]] -> [Doc]) -> ([Pos] -> [[Pos]]) -> [Pos] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pos -> Pos -> Bool) -> [Pos] -> [[Pos]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((String -> String -> Bool) -> (Pos -> String) -> Pos -> Pos -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) Pos -> String
sourceName) ([Pos] -> [[Pos]]) -> ([Pos] -> [Pos]) -> [Pos] -> [[Pos]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pos] -> [Pos]
forall a. Ord a => [a] -> [a]
sort

instance Pretty Range where
    pretty :: Range -> Doc
pretty = [Pos] -> Doc
prettyRange ([Pos] -> Doc) -> (Range -> [Pos]) -> Range -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> [Pos]
rangeToList

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

filterDiags :: Int -> [Diagnosis] -> [Diagnosis]
filterDiags :: Int -> [Diagnosis] -> [Diagnosis]
filterDiags v :: Int
v = (Diagnosis -> Bool) -> [Diagnosis] -> [Diagnosis]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Diagnosis -> Bool) -> [Diagnosis] -> [Diagnosis])
-> (Diagnosis -> Bool) -> [Diagnosis] -> [Diagnosis]
forall a b. (a -> b) -> a -> b
$ Int -> DiagKind -> Bool
relevantDiagKind Int
v (DiagKind -> Bool) -> (Diagnosis -> DiagKind) -> Diagnosis -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diagnosis -> DiagKind
diagKind

showRelDiags :: Int -> [Diagnosis] -> String
showRelDiags :: Int -> [Diagnosis] -> String
showRelDiags v :: Int
v = [String] -> String
unlines ([String] -> String)
-> ([Diagnosis] -> [String]) -> [Diagnosis] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Diagnosis -> String) -> [Diagnosis] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Diagnosis -> String
forall a. Show a => a -> String
show ([Diagnosis] -> [String])
-> ([Diagnosis] -> [Diagnosis]) -> [Diagnosis] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Diagnosis] -> [Diagnosis]
filterDiags Int
v

printDiags :: Int -> [Diagnosis] -> IO ()
printDiags :: Int -> [Diagnosis] -> IO ()
printDiags v :: Int
v = String -> IO ()
putStr (String -> IO ())
-> ([Diagnosis] -> String) -> [Diagnosis] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Diagnosis] -> String
showRelDiags Int
v

instance Show Diagnosis where
    showsPrec :: Int -> Diagnosis -> ShowS
showsPrec _ = Doc -> ShowS
forall a. Show a => a -> ShowS
shows (Doc -> ShowS) -> (Diagnosis -> Doc) -> Diagnosis -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diagnosis -> Doc
forall a. Pretty a => a -> Doc
pretty

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

instance GetRange Diagnosis where
    getRange :: Diagnosis -> Range
getRange = Diagnosis -> Range
diagPos

instance Pretty a => Pretty (Result a) where
    pretty :: Result a -> Doc
pretty (Result ds :: [Diagnosis]
ds m :: Maybe a
m) = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Maybe a -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe a
m Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Diagnosis -> Doc) -> [Diagnosis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Diagnosis -> Doc
forall a. Pretty a => a -> Doc
pretty [Diagnosis]
ds