{-# LANGUAGE FlexibleContexts #-}


-- | Provides error handling functions for checking parser output.
--   The functions and data types of this module are mostly tiny, little
--   helpers used by all parser modules.

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)



-- | A wrapper type for a @Writer@ which stores pretty-printable documents along
--   with checked values.

type Checked a = Writer [Doc] a



-- | A wrapper type for @Writer@ which stores pretty-printable documents along
--   with parsed values.
--   This type is provided as standard return type for parsers.

type Parsed a = Writer [Doc] a





-- | The error type is just a synonym for @Either@ where errors are represented
--   by a pretty-printable @Doc@.

type ErrorOr a = Either Doc a

-- needed to make 'ErrorOr' a monad
instance Error Doc where
  noMsg :: Doc
noMsg    = Doc
empty
  strMsg :: String -> Doc
strMsg String
s = String -> Doc
text String
s



-- | A wrapper function for @runWriter@.

runChecks :: Checked a -> (a, [Doc])
runChecks :: forall a. Checked a -> (a, [Doc])
runChecks = forall w a. Writer w a -> (a, w)
runWriter



-- | Applies a checking function (the first argument) element-wise to a list of
--   values (the second argument). The result list contains only those elements
--   for which the checking function does not yield an error.

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



-- | Checks if the argument contains an error.

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)



-- | Returns the error message stored in the argument or @Nothing@ if there is 
--   no error message in the argument.

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)



-- | If the first argument is True, then the second argument is taken as an
--   error message. Otherwise () is returned as a non-error message.

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



-- | Transforms a string into a pretty-printed document by splitting the string
--   into words and forming a pretty paragraph of all words.

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



-- | Checks a declaration for errors.
--   If the second argument is an error, this function extends the error 
--   message to make clear it belongs to a declaration.

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
    


-- | Used to extend error messages by a list of items violating a certain rule. 

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)