bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder{- |

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian MaederModule : $Header$

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian MaederDescription : Result monad for accumulating Diagnosis messages

97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederCopyright : (c) T. Mossakowski, C. Maeder, Uni Bremen 2002-2008

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

b4fbc96e05117839ca409f5f20f97b3ac872d1edTill Mossakowski

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian MaederMaintainer : Christian.Maeder@dfki.de

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian MaederStability : provisional

f3a94a197960e548ecd6520bb768cb0d547457bbChristian MaederPortability : portable

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder'Result' monad for accumulating 'Diagnosis' messages

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder during analysis phases.

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder-}

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maedermodule Common.Result

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder ( DiagKind(..)

ee9eddfa6953868fd6fbaff0d9ff68675a13675aChristian Maeder , Diagnosis(..)

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder , mkDiag

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder , mkNiceDiag

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder , isErrorDiag

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder , hasErrors

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , checkUniqueness

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder , Result(..)

ee9eddfa6953868fd6fbaff0d9ff68675a13675aChristian Maeder , appendDiags

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder , joinResultWith

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder , joinResult

33a5d53a412ba0a4e5847f7538d6da2e22bd116cChristian Maeder , mapR

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , fatal_error

e774ab5733a1d673b123b0e63b14dd533e6fd4fcChristian Maeder , mkError

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder , debug

b645cf3dc1e449038ed291bbd11fcc6e02b2fc7fChristian Maeder , plain_error

ebcaad207cafc89eeb49d431f40de2ef4c48411cChristian Maeder , warning

b645cf3dc1e449038ed291bbd11fcc6e02b2fc7fChristian Maeder , hint

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , message

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , maybeToResult

b645cf3dc1e449038ed291bbd11fcc6e02b2fc7fChristian Maeder , maybeToMonad

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , resultToMaybe

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , adjustPos

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , propagateErrors

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , showErr

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , filterDiags

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , showRelDiags

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder , printDiags

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder ) where

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maederimport Common.Id

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maederimport Common.Doc

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maederimport Common.DocUtils

38775225cf810f5895cc03b4acbcfe8f84f2513aChristian Maederimport Common.GlobalAnnotations

ccf3de3d66b521a260e5c22d335c64a48e3f0195Christian Maederimport Data.List

ccf3de3d66b521a260e5c22d335c64a48e3f0195Christian Maederimport Text.ParserCombinators.Parsec.Error

ccf3de3d66b521a260e5c22d335c64a48e3f0195Christian Maederimport Text.ParserCombinators.Parsec.Char (char)

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maederimport Text.ParserCombinators.Parsec (parse)

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maederimport Common.Lexer

dfa74d066ea0f00a70276aedecc624c6b3c86deaChristian Maederimport Control.Monad

ccf3de3d66b521a260e5c22d335c64a48e3f0195Christian Maeder

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder-- | severness of diagnostic messages

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maederdata DiagKind = Error | Warning | Hint | Debug

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder | MessageW -- ^ used for messages in the web interface

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder deriving (Eq, Ord, Show)

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder-- | a diagnostic message with 'Pos'

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maederdata Diagnosis = Diag { diagKind :: DiagKind

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder , diagString :: String

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder , diagPos :: Range

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder } deriving Eq

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder-- | construct a message for a printable item that carries a position

715ffaf874309df081d1e1cd8e05073fc1227729Christian MaedermkDiag :: (GetRange a, Pretty a) => DiagKind -> String -> a -> Diagnosis

d17834302eaa101395b4b806cd73670fd864445fChristian MaedermkDiag k s a = let q = text "'" in

ccf3de3d66b521a260e5c22d335c64a48e3f0195Christian Maeder Diag k (show $ sep [text s, q <> pretty a <> q]) $ getRange a

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder-- | construct a message for a printable item that carries a position

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian MaedermkNiceDiag :: (GetRange a, Pretty a) => GlobalAnnos

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder -> DiagKind -> String -> a -> Diagnosis

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian MaedermkNiceDiag ga k s a = let q = text "'" in

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder Diag k (show (toText ga $ sep [text s, q <> pretty a <> q])) $ getRange a

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder-- | check whether a diagnosis is an error

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaederisErrorDiag :: Diagnosis -> Bool

715ffaf874309df081d1e1cd8e05073fc1227729Christian MaederisErrorDiag d = case diagKind d of

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder Error -> True

715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder _ -> False

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder-- | Check whether a diagnosis list contains errors

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian MaederhasErrors :: [Diagnosis] -> Bool

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian MaederhasErrors = any isErrorDiag

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder

836e72a3c413366ba9801726f3b249c7791cb9caChristian Maeder-- | add range to a diagnosis

836e72a3c413366ba9801726f3b249c7791cb9caChristian MaederadjustDiagPos :: Range -> Diagnosis -> Diagnosis

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaederadjustDiagPos r d = if isNullRange $ diagPos d then d { diagPos = r } else d

7dec34aee2b609b9535c48d060e0f7baf3536457Christian Maeder

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder-- | A uniqueness check yields errors for duplicates in a given list.

7dec34aee2b609b9535c48d060e0f7baf3536457Christian MaedercheckUniqueness :: (Pretty a, GetRange a, Ord a) => [a] -> [Diagnosis]

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian MaedercheckUniqueness l =

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder let vd = filter ( not . null . tail) $ group $ sort l

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder in map ( \ vs -> mkDiag Error ("duplicates at '" ++

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder showSepList (showString " ") shortPosShow

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder (concatMap getPosList (tail vs)) "'"

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder ++ " for") (head vs)) vd

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder where shortPosShow :: Pos -> ShowS

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder shortPosShow p = showParen True

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder (shows (sourceLine p) .

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder showString "," .

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder shows (sourceColumn p))

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder

797f811e57952d59e73b8cd03b667eef276db972Christian Maeder-- | The result monad. A failing result should include an error message.

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maederdata Result a = Result { diags :: [Diagnosis]

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder , maybeResult :: Maybe a

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder } deriving Show

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maederinstance Functor Result where

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder fmap f (Result errs m) = Result errs $ fmap f m

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maederinstance Monad Result where

bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maeder return x = Result [] $ Just x

ccf3de3d66b521a260e5c22d335c64a48e3f0195Christian Maeder r@(Result e m) >>= f = case m of

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder Nothing -> Result e Nothing

d17834302eaa101395b4b806cd73670fd864445fChristian Maeder Just x -> joinResult r $ f x

e1839fb37a3a2ccd457464cb0dcc5efd466dbe22Christian Maeder fail s = fatal_error s nullRange

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder

e774ab5733a1d673b123b0e63b14dd533e6fd4fcChristian Maederinstance MonadPlus Result where

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder mzero = Result [] Nothing

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder r1@(Result _ m) `mplus` r2 = case m of

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder Nothing -> r2

7dec34aee2b609b9535c48d060e0f7baf3536457Christian Maeder Just _ -> r1

7dec34aee2b609b9535c48d060e0f7baf3536457Christian Maeder

1738d16957389457347bee85075d3d33d002158fChristian Maeder

1738d16957389457347bee85075d3d33d002158fChristian MaederappendDiags :: [Diagnosis] -> Result ()

1738d16957389457347bee85075d3d33d002158fChristian MaederappendDiags ds = Result ds (Just ())

33a5d53a412ba0a4e5847f7538d6da2e22bd116cChristian Maeder

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder-- | join two results with a combining function

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaederjoinResultWith :: (a -> b -> c) -> Result a -> Result b -> Result c

2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaederjoinResultWith f (Result d1 m1) (Result d2 m2) = Result (d1 ++ d2) $

0f67ca7b0c738a28f6688ba6e96d44d7c14af611Christian Maeder do r1 <- m1

c70d42540b8f8c3c141cc0779599d25f7eb69bbfChristian Maeder r2 <- m2

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder return $ f r1 r2

b645cf3dc1e449038ed291bbd11fcc6e02b2fc7fChristian Maeder

5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder-- | join two results

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaederjoinResult :: Result a -> Result b -> Result b

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaederjoinResult = joinResultWith (\ _ b -> b)

88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maeder

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder-- | join a list of results that are independently computed

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaedermapR :: (a -> Result b) -> [a] -> Result [b]

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaedermapR ana = foldr (joinResultWith (:)) (Result [] $ Just []) . map ana

88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maeder

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder-- | a failing result with a proper position

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maederfatal_error :: String -> Range -> Result a

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maederfatal_error s p = Result [Diag Error s p] Nothing

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder-- | a failing result constructing a message from a type

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaedermkError :: (GetRange a, Pretty a) => String -> a -> Result b

88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian MaedermkError s c = Result [mkDiag Error s c] Nothing

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder-- | add a debug point

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maederdebug :: (GetRange a, Pretty a) => Int -> (String, a) -> Result ()

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maederdebug n (s, a) = Result

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder [mkDiag Debug (unlines [" point " ++ show n, "Variable "++ s ++":"]) a ]

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder $ Just ()

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder-- | add an error message but don't fail

88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maederplain_error :: a -> String -> Range -> Result a

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maederplain_error x s p = Result [Diag Error s p] $ Just x

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder-- | add a warning

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maederwarning :: a -> String -> Range -> Result a

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maederwarning x s p = Result [Diag Warning s p] $ Just x

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder-- | add a hint

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maederhint :: a -> String -> Range -> Result a

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maederhint x s p = Result [Diag Hint s p] $ Just x

1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder

88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maeder-- | add a (web interface) message

aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maedermessage :: 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

-- | add a failure message to 'Nothing'

-- (alternative for 'maybeToResult' without 'Range')

maybeToMonad :: Monad m => String -> Maybe a -> m a

maybeToMonad s m = case m of

Nothing -> fail s

Just v -> return v

-- | check whether no errors are present, coerce into 'Maybe'

resultToMaybe :: Result a -> Maybe a

resultToMaybe (Result ds val) = if hasErrors ds then Nothing else val

-- | 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

propagateErrors :: Result a -> a

propagateErrors r =

case (hasErrors $ diags r, maybeResult r) of

(False, Just x) -> x

_ -> error $ showRelDiags 2 $ diags r

-- | 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 ps = sepByCommas $ map prettySingleSourceRange

$ groupBy (\ p1 p2 -> sourceName p1 == sourceName p2) $ sort ps

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

[(if isMessageW

then empty

else text (case k of

Error -> "***"

_ -> "###") <+> text (show k))

<> (case sp of

[] | isMessageW -> empty

| otherwise -> comma

_ -> space <> prettyRange sp <> comma)

, text s]

where isMessageW = case k of

MessageW -> True

_ -> False

instance GetRange Diagnosis where

getRange d = diagPos d

instance Pretty a => Pretty (Result a) where

pretty (Result ds m) = vcat $ pretty m : map pretty ds