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