{-|
Module      : Prosidy.Compile.Error
Description : Error definitions and utility functions.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module Prosidy.Compile.Error
    ( Error(..)
    , TagKind(..)
    , ErrorSet
    , Error'
    , ErrorSet'
    , IsError
    , MonadErrors
    , singleError
    , customError
    , throwError1
    , allErrors
    , attachLocation
    , MonadError(..)
    )
where

import           Lens.Micro

import           Control.Exception              ( Exception(..) )
import           Prosidy.Types.Key              ( Key )
import           Prosidy.Source                 ( Line(..)
                                                , Column(..)
                                                , Location
                                                )
import           Prosidy.Optics.Source          ( HasLocation(..)
                                                , line
                                                , column
                                                )
import           Data.HashSet                   ( HashSet
                                                , singleton
                                                )
import           Control.Monad.Except           ( MonadError(..)
                                                , throwError
                                                )
import           GHC.Generics                   ( Generic )
import           Data.Hashable                  ( Hashable )
import           Data.Typeable                  ( Typeable )
import           Data.Void                      ( Void )
import           Data.Foldable                  ( toList )
import           Data.List.NonEmpty             ( NonEmpty(..)
                                                , nonEmpty
                                                )

-- | A contraint alias for types returning at least one error.
type MonadErrors e = MonadError (ErrorSet e)

-- | A constraint alias for errors throwable in a context admitting a 
-- 'MonadErrors' instance.
type IsError e = (Exception e, Hashable e, Eq e)

-- | A non-empty set of errors. 
newtype ErrorSet e =
    ErrorSet (HashSet (Error e))
  deriving stock (Int -> ErrorSet e -> ShowS
[ErrorSet e] -> ShowS
ErrorSet e -> String
(Int -> ErrorSet e -> ShowS)
-> (ErrorSet e -> String)
-> ([ErrorSet e] -> ShowS)
-> Show (ErrorSet e)
forall e. Show e => Int -> ErrorSet e -> ShowS
forall e. Show e => [ErrorSet e] -> ShowS
forall e. Show e => ErrorSet e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorSet e] -> ShowS
$cshowList :: forall e. Show e => [ErrorSet e] -> ShowS
show :: ErrorSet e -> String
$cshow :: forall e. Show e => ErrorSet e -> String
showsPrec :: Int -> ErrorSet e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> ErrorSet e -> ShowS
Show, (forall x. ErrorSet e -> Rep (ErrorSet e) x)
-> (forall x. Rep (ErrorSet e) x -> ErrorSet e)
-> Generic (ErrorSet e)
forall x. Rep (ErrorSet e) x -> ErrorSet e
forall x. ErrorSet e -> Rep (ErrorSet e) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e x. Rep (ErrorSet e) x -> ErrorSet e
forall e x. ErrorSet e -> Rep (ErrorSet e) x
$cto :: forall e x. Rep (ErrorSet e) x -> ErrorSet e
$cfrom :: forall e x. ErrorSet e -> Rep (ErrorSet e) x
Generic, ErrorSet e -> ErrorSet e -> Bool
(ErrorSet e -> ErrorSet e -> Bool)
-> (ErrorSet e -> ErrorSet e -> Bool) -> Eq (ErrorSet e)
forall e. Eq e => ErrorSet e -> ErrorSet e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorSet e -> ErrorSet e -> Bool
$c/= :: forall e. Eq e => ErrorSet e -> ErrorSet e -> Bool
== :: ErrorSet e -> ErrorSet e -> Bool
$c== :: forall e. Eq e => ErrorSet e -> ErrorSet e -> Bool
Eq)
  deriving anyclass (Int -> ErrorSet e -> Int
ErrorSet e -> Int
(Int -> ErrorSet e -> Int)
-> (ErrorSet e -> Int) -> Hashable (ErrorSet e)
forall e. Hashable e => Int -> ErrorSet e -> Int
forall e. Hashable e => ErrorSet e -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: ErrorSet e -> Int
$chash :: forall e. Hashable e => ErrorSet e -> Int
hashWithSalt :: Int -> ErrorSet e -> Int
$chashWithSalt :: forall e. Hashable e => Int -> ErrorSet e -> Int
Hashable)

instance IsError e => Semigroup (ErrorSet e) where
    ErrorSet lhs :: HashSet (Error e)
lhs <> :: ErrorSet e -> ErrorSet e -> ErrorSet e
<> ErrorSet rhs :: HashSet (Error e)
rhs = HashSet (Error e) -> ErrorSet e
forall e. HashSet (Error e) -> ErrorSet e
ErrorSet (HashSet (Error e) -> ErrorSet e)
-> HashSet (Error e) -> ErrorSet e
forall a b. (a -> b) -> a -> b
$! HashSet (Error e)
lhs HashSet (Error e) -> HashSet (Error e) -> HashSet (Error e)
forall a. Semigroup a => a -> a -> a
<> HashSet (Error e)
rhs

-- | A type alias for 'ErrorSet's which never contain empty errors.
type ErrorSet' = ErrorSet Void

-- | Enumerates the errors thrown when 
data Error a =
    Custom a
    -- ^ A custom error, allowing extensibility.
  | ParseError Key String
    -- ^ Thrown when parsing a setting fails.
  | Required Key
    -- ^ Thrown when a setting was required to be set, but wasn't provided.
  | ExpectedTag TagKind Key
    -- ^ Thrown when matching against a 'Prosidy.Tag', and another node was 
    -- found, or the input tag's 'Key' didn't match the specified key.
  | ExpectedParagraph
    -- ^ Thrown when matching against paragraph and an unexpected node was
    -- encountered.
  | ExpectedText
    -- ^ Thrown when matching against text and an unexpected node was
    -- encountered.
  | ExpectedBreak
    -- ^ Thrown when matching against an explicit break and an unexpected node
    -- was encountered.
  | EmptyMatch
    -- ^ Thrown when a match has no cases to check against.
  | Group (Maybe Location) (ErrorSet a)
    -- ^ Used to group a set of errors thrown at the same point in a tree.
    -- If a location is available, we attach it for debugging.
  deriving (Error a -> Error a -> Bool
(Error a -> Error a -> Bool)
-> (Error a -> Error a -> Bool) -> Eq (Error a)
forall a. Eq a => Error a -> Error a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error a -> Error a -> Bool
$c/= :: forall a. Eq a => Error a -> Error a -> Bool
== :: Error a -> Error a -> Bool
$c== :: forall a. Eq a => Error a -> Error a -> Bool
Eq, Int -> Error a -> ShowS
[Error a] -> ShowS
Error a -> String
(Int -> Error a -> ShowS)
-> (Error a -> String) -> ([Error a] -> ShowS) -> Show (Error a)
forall a. Show a => Int -> Error a -> ShowS
forall a. Show a => [Error a] -> ShowS
forall a. Show a => Error a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error a] -> ShowS
$cshowList :: forall a. Show a => [Error a] -> ShowS
show :: Error a -> String
$cshow :: forall a. Show a => Error a -> String
showsPrec :: Int -> Error a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Error a -> ShowS
Show, (forall x. Error a -> Rep (Error a) x)
-> (forall x. Rep (Error a) x -> Error a) -> Generic (Error a)
forall x. Rep (Error a) x -> Error a
forall x. Error a -> Rep (Error a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Error a) x -> Error a
forall a x. Error a -> Rep (Error a) x
$cto :: forall a x. Rep (Error a) x -> Error a
$cfrom :: forall a x. Error a -> Rep (Error a) x
Generic, Int -> Error a -> Int
Error a -> Int
(Int -> Error a -> Int) -> (Error a -> Int) -> Hashable (Error a)
forall a. Hashable a => Int -> Error a -> Int
forall a. Hashable a => Error a -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Error a -> Int
$chash :: forall a. Hashable a => Error a -> Int
hashWithSalt :: Int -> Error a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> Error a -> Int
Hashable)

instance (Typeable a, Exception a) => Exception (Error a) where
    displayException :: Error a -> String
displayException (Custom a :: a
a        ) = a -> String
forall e. Exception e => e -> String
displayException a
a

    displayException (ParseError k :: Key
k msg :: String
msg) = [ShowS] -> ShowS
forall a. Monoid a => [a] -> a
mconcat
        [ String -> ShowS
showString "failed to parse the setting "
        , Key -> ShowS
forall a. Show a => a -> ShowS
shows Key
k
        , String -> ShowS
showString ": "
        , String -> ShowS
showString String
msg
        ]
        ""

    displayException EmptyMatch   = "Match provided with no possible cases."

    displayException (Required k :: Key
k) = "missing required setting " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Key -> String
forall a. Show a => a -> String
show Key
k

    displayException (ExpectedTag kind :: TagKind
kind k :: Key
k) =
        "expected a " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TagKind -> String
forall a. Show a => a -> String
show TagKind
kind String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " tag with key " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Key -> String
forall a. Show a => a -> String
show Key
k

    displayException ExpectedParagraph    = "expected a paragrapgh"

    displayException ExpectedText         = "expected plain text"

    displayException ExpectedBreak        = "expected a break"

    displayException (Group (Just loc :: Location
loc) x :: ErrorSet a
x) = [ShowS] -> ShowS
forall a. Monoid a => [a] -> a
mconcat
        [ String -> ShowS
showString "error(s) encountered at line "
        , Word -> ShowS
forall a. Show a => a -> ShowS
shows (Location
loc Location -> Getting (Endo Word) Location Word -> Word
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Optic' (->) (Const (Endo Word)) Location Line
forall l (f :: * -> *).
(HasLocation l, Contravariant f, Applicative f) =>
Optic' (->) f l Line
line Optic' (->) (Const (Endo Word)) Location Line
-> ((Word -> Const (Endo Word) Word)
    -> Line -> Const (Endo Word) Line)
-> Getting (Endo Word) Location Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Word) -> SimpleGetter Line Word
forall s a. (s -> a) -> SimpleGetter s a
to (\(Line n :: Word
n) -> Word -> Word
forall a. Enum a => a -> a
succ Word
n))
        , String -> ShowS
showString " column "
        , Word -> ShowS
forall a. Show a => a -> ShowS
shows (Location
loc Location -> Getting (Endo Word) Location Word -> Word
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Optic' (->) (Const (Endo Word)) Location Column
forall l (f :: * -> *).
(HasLocation l, Contravariant f, Applicative f) =>
Optic' (->) f l Column
column Optic' (->) (Const (Endo Word)) Location Column
-> ((Word -> Const (Endo Word) Word)
    -> Column -> Const (Endo Word) Column)
-> Getting (Endo Word) Location Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Column -> Word) -> SimpleGetter Column Word
forall s a. (s -> a) -> SimpleGetter s a
to (\(Column n :: Word
n) -> Word -> Word
forall a. Enum a => a -> a
succ Word
n))
        , String -> ShowS
showString ":\n"
        , (Error a -> ShowS) -> NonEmpty (Error a) -> ShowS
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
            (\exn :: Error a
exn -> String -> ShowS
showString (Error a -> String
forall e. Exception e => e -> String
displayException Error a
exn) ShowS -> ShowS -> ShowS
forall a. Semigroup a => a -> a -> a
<> Char -> ShowS
showChar '\n')
            (ErrorSet a -> NonEmpty (Error a)
forall e. ErrorSet e -> NonEmpty (Error e)
allErrors ErrorSet a
x)
        ]
        ""

    displayException (Group Nothing x :: ErrorSet a
x) = (Error a -> ShowS) -> NonEmpty (Error a) -> ShowS
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        (\exn :: Error a
exn -> String -> ShowS
showString (Error a -> String
forall e. Exception e => e -> String
displayException Error a
exn) ShowS -> ShowS -> ShowS
forall a. Semigroup a => a -> a -> a
<> Char -> ShowS
showChar '\n')
        (ErrorSet a -> NonEmpty (Error a)
forall e. ErrorSet e -> NonEmpty (Error e)
allErrors ErrorSet a
x)
        ""

-- | A type alias for 'Error's that never throw a custom error.
type Error' = Error Void

-- | A marker class for marking which type of tag 'ExpectedTag' was expecting.
data TagKind = BlockKind | InlineKind | LiteralKind
  deriving (Int -> TagKind -> ShowS
[TagKind] -> ShowS
TagKind -> String
(Int -> TagKind -> ShowS)
-> (TagKind -> String) -> ([TagKind] -> ShowS) -> Show TagKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagKind] -> ShowS
$cshowList :: [TagKind] -> ShowS
show :: TagKind -> String
$cshow :: TagKind -> String
showsPrec :: Int -> TagKind -> ShowS
$cshowsPrec :: Int -> TagKind -> ShowS
Show, TagKind -> TagKind -> Bool
(TagKind -> TagKind -> Bool)
-> (TagKind -> TagKind -> Bool) -> Eq TagKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagKind -> TagKind -> Bool
$c/= :: TagKind -> TagKind -> Bool
== :: TagKind -> TagKind -> Bool
$c== :: TagKind -> TagKind -> Bool
Eq, (forall x. TagKind -> Rep TagKind x)
-> (forall x. Rep TagKind x -> TagKind) -> Generic TagKind
forall x. Rep TagKind x -> TagKind
forall x. TagKind -> Rep TagKind x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TagKind x -> TagKind
$cfrom :: forall x. TagKind -> Rep TagKind x
Generic, Int -> TagKind -> Int
TagKind -> Int
(Int -> TagKind -> Int) -> (TagKind -> Int) -> Hashable TagKind
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: TagKind -> Int
$chash :: TagKind -> Int
hashWithSalt :: Int -> TagKind -> Int
$chashWithSalt :: Int -> TagKind -> Int
Hashable)

-- | Group errors together, attaching a location if one is available.
attachLocation :: (IsError e, MonadErrors e m, HasLocation l) => l -> m a -> m a
attachLocation :: l -> m a -> m a
attachLocation item :: l
item = (m a -> (ErrorSet e -> m a) -> m a)
-> (ErrorSet e -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (ErrorSet e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ((ErrorSet e -> m a) -> m a -> m a)
-> (ErrorSet e -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Error e -> m a
forall e (m :: * -> *) a.
(Hashable e, MonadErrors e m) =>
Error e -> m a
throwError1 (Error e -> m a) -> (ErrorSet e -> Error e) -> ErrorSet e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> ErrorSet e -> Error e
forall a. Maybe Location -> ErrorSet a -> Error a
Group (l
item l -> Getting (First Location) l Location -> Maybe Location
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Location) l Location
forall t. HasLocation t => Affine' t Location
location)

-- | Lift a single 'Error' into an 'ErrorSet'.
singleError :: Hashable e => Error e -> ErrorSet e
singleError :: Error e -> ErrorSet e
singleError = HashSet (Error e) -> ErrorSet e
forall e. HashSet (Error e) -> ErrorSet e
ErrorSet (HashSet (Error e) -> ErrorSet e)
-> (Error e -> HashSet (Error e)) -> Error e -> ErrorSet e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error e -> HashSet (Error e)
forall a. Hashable a => a -> HashSet a
singleton
{-# INLINE singleError #-}

-- | Lift a custom error into an 'ErrorSet'.
customError :: Hashable e => e -> ErrorSet e
customError :: e -> ErrorSet e
customError = Error e -> ErrorSet e
forall e. Hashable e => Error e -> ErrorSet e
singleError (Error e -> ErrorSet e) -> (e -> Error e) -> e -> ErrorSet e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Error e
forall a. a -> Error a
Custom
{-# INLINE customError #-}

-- | Throw a single error.
throwError1 :: Hashable e => MonadErrors e m => Error e -> m a
throwError1 :: Error e -> m a
throwError1 = ErrorSet e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorSet e -> m a) -> (Error e -> ErrorSet e) -> Error e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error e -> ErrorSet e
forall e. Hashable e => Error e -> ErrorSet e
singleError
{-# INLINE throwError1 #-}

-- | Return the set of errors in an 'ErrorSet' as a non-empty list.
allErrors :: ErrorSet e -> NonEmpty (Error e)
allErrors :: ErrorSet e -> NonEmpty (Error e)
allErrors (ErrorSet hs :: HashSet (Error e)
hs) =
    NonEmpty (Error e)
-> (NonEmpty (Error e) -> NonEmpty (Error e))
-> Maybe (NonEmpty (Error e))
-> NonEmpty (Error e)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NonEmpty (Error e)
forall a. HasCallStack => String -> a
error "unexpected empty ErrorSet") NonEmpty (Error e) -> NonEmpty (Error e)
forall a. a -> a
id (Maybe (NonEmpty (Error e)) -> NonEmpty (Error e))
-> ([Error e] -> Maybe (NonEmpty (Error e)))
-> [Error e]
-> NonEmpty (Error e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error e] -> Maybe (NonEmpty (Error e))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Error e] -> NonEmpty (Error e))
-> [Error e] -> NonEmpty (Error e)
forall a b. (a -> b) -> a -> b
$ HashSet (Error e) -> [Error e]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet (Error e)
hs