Error.hs

{-|
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 (Show, Generic, Eq)
  deriving anyclass (Hashable)

instance IsError e => Semigroup (ErrorSet e) where
    ErrorSet lhs <> ErrorSet rhs = ErrorSet $! lhs <> 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 (Eq, Show, Generic, Hashable)

instance (Typeable a, Exception a) => Exception (Error a) where
    displayException (Custom a        ) = displayException a

    displayException (ParseError k msg) = mconcat
        [ showString "failed to parse the setting "
        , shows k
        , showString ": "
        , showString msg
        ]
        ""

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

    displayException (Required k) = "missing required setting " <> show k

    displayException (ExpectedTag kind k) =
        "expected a " <> show kind <> " tag with key " <> show k

    displayException ExpectedParagraph    = "expected a paragrapgh"

    displayException ExpectedText         = "expected plain text"

    displayException ExpectedBreak        = "expected a break"

    displayException (Group (Just loc) x) = mconcat
        [ showString "error(s) encountered at line "
        , shows (loc ^?! line . to (\(Line n) -> succ n))
        , showString " column "
        , shows (loc ^?! column . to (\(Column n) -> succ n))
        , showString ":\n"
        , foldMap
            (\exn -> showString (displayException exn) <> showChar '\n')
            (allErrors x)
        ]
        ""

    displayException (Group Nothing x) = foldMap
        (\exn -> showString (displayException exn) <> showChar '\n')
        (allErrors 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 (Show, Eq, Generic, 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 item = flip catchError $ throwError1 . Group (item ^? location)

-- | Lift a single 'Error' into an 'ErrorSet'.
singleError :: Hashable e => Error e -> ErrorSet e
singleError = ErrorSet . singleton
{-# INLINE singleError #-}

-- | Lift a custom error into an 'ErrorSet'.
customError :: Hashable e => e -> ErrorSet e
customError = singleError . Custom
{-# INLINE customError #-}

-- | Throw a single error.
throwError1 :: Hashable e => MonadErrors e m => Error e -> m a
throwError1 = throwError . singleError
{-# INLINE throwError1 #-}

-- | Return the set of errors in an 'ErrorSet' as a non-empty list.
allErrors :: ErrorSet e -> NonEmpty (Error e)
allErrors (ErrorSet hs) =
    maybe (error "unexpected empty ErrorSet") id . nonEmpty $ toList hs