{-# LANGUAGE FlexibleContexts #-}
module Language.Haskell.FreeTheorems.Frontend.Error where
import Control.Monad (foldM)
import Control.Monad.Error (Error(..), throwError)
import Control.Monad.Writer (Writer, runWriter, tell)
import Data.List (intersperse)
import Text.PrettyPrint (Doc, empty, text, fsep, ($$), nest)
import Language.Haskell.FreeTheorems.Syntax
(Declaration, getDeclarationName, unpackIdent)
type Checked a = Writer [Doc] a
type Parsed a = Writer [Doc] a
type ErrorOr a = Either Doc a
instance Error Doc where
noMsg :: Doc
noMsg = Doc
empty
strMsg :: String -> Doc
strMsg String
s = String -> Doc
text String
s
runChecks :: Checked a -> (a, [Doc])
runChecks :: forall a. Checked a -> (a, [Doc])
runChecks = forall w a. Writer w a -> (a, w)
runWriter
foldChecks :: (a -> ErrorOr b) -> [a] -> Checked [a]
foldChecks :: forall a b. (a -> ErrorOr b) -> [a] -> Checked [a]
foldChecks a -> ErrorOr b
check = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *}. MonadWriter [Doc] m => [a] -> a -> m [a]
doCheck []
where
doCheck :: [a] -> a -> m [a]
doCheck [a]
xs a
x =
case forall a. ErrorOr a -> Maybe Doc
getError (a -> ErrorOr b
check a
x) of
Maybe Doc
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs forall a. [a] -> [a] -> [a]
++ [a
x])
Just Doc
e -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Doc
e] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
isError :: ErrorOr a -> Bool
isError :: forall a. ErrorOr a -> Bool
isError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
True) (forall a b. a -> b -> a
const Bool
False)
getError :: ErrorOr a -> Maybe Doc
getError :: forall a. ErrorOr a -> Maybe Doc
getError = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
errorIf :: Bool -> Doc -> ErrorOr ()
errorIf :: Bool -> Doc -> ErrorOr ()
errorIf Bool
False = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const ()
errorIf Bool
True = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
pp :: String -> Doc
pp :: String -> Doc
pp = [Doc] -> Doc
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
inDecl :: Declaration -> ErrorOr a -> ErrorOr a
inDecl :: forall a. Declaration -> ErrorOr a -> ErrorOr a
inDecl Declaration
d ErrorOr a
e = case forall a. ErrorOr a -> Maybe Doc
getError ErrorOr a
e of
Maybe Doc
Nothing -> ErrorOr a
e
Just Doc
doc -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
String -> Doc
pp (String
"In the declaration of "
forall a. [a] -> [a] -> [a]
++ Identifier -> String
unpackIdent (Declaration -> Identifier
getDeclarationName Declaration
d) forall a. [a] -> [a] -> [a]
++ String
":")
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 Doc
doc
violating :: String -> [String] -> String
violating :: String -> [String] -> String
violating String
name [String]
xs =
let text :: String
text = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs forall a. Eq a => a -> a -> Bool
== Int
1
then String
" The following " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" violates this rule: "
else String
" The following " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"s violate this rule: "
in String
text forall a. [a] -> [a] -> [a]
++ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse String
", " forall a b. (a -> b) -> a -> b
$ [String]
xs)