{-|
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 DerivingVia #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
module Prosidy.Compile.Error
    ( Error(..)
    , TagKind(..)
    , MetadataKind(..)
    , ErrorSet
    , Error'
    , ErrorSet'
    , IsError
    , ApError(..)
    , ApErrors
    , singleError
    , customError
    , liftError1
    , allErrors
    , groupErrors
    )
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           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
                                                )

-- | Similar to 'Control.Monad.Except.MonadError', but without the 'Monad'
-- constraint, and without a method to handle errors, only a method to map over
-- them.
class Applicative f => ApError e f | f -> e where
    liftError :: e -> f a
    mapError  :: (e -> e) -> f a -> f a

-- | A synonym for 'ApError' when the underlying applicative is capable of
-- accumulating errors in an 'ErrorSet'.
type ApErrors e = ApError (ErrorSet e)

-- | A constraint alias for errors throwable in a context admitting a
-- 'ApErrors' 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 Exception e => Exception (ErrorSet e) where
    displayException (ErrorSet errors) = mconcat
        [ showString "encountered " <> shows (length errors) <> showString
            " error(s):\n"
        , showString "-----\n"
        , foldMap (\x -> showString (displayException x) . showChar '\n') errors
        ]
        ""

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.
  | UnknownMetadata (HashSet (MetadataKind, Key))
    -- ^ Thrown when an unknown property or setting is encountered when
    -- checking that properties and settings conform to strictly known
    -- keys.
  | Group (Maybe Location) (ErrorSet a)
    -- ^ Used to group a set of errors thrown at the same point in a tree.
  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 " <> kindstr kind <> " tag with key " <> show k
      where
        kindstr BlockKind   = "block"
        kindstr InlineKind  = "inline"
        kindstr LiteralKind = "literal"

    displayException ExpectedParagraph = "expected a paragrapgh"

    displayException ExpectedText      = "expected plain text"

    displayException ExpectedBreak     = "expected a break"

    displayException (UnknownMetadata xs) =
        showString "One or more invalid metadata items were encountered:"
            <> foldMap showItem xs
            $  ""
      where
        showItem (PropertyKind, key) =
            showChar ' ' <> shows key <> showString " (property)"
        showItem (SettingKind, key) =
            showChar ' ' <> shows key <> showString " (setting)"

    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)

-- | A marker class for marking which type of metadata (settings or property)
-- a key corresponds to.
data MetadataKind = PropertyKind | SettingKind
  deriving (Show, Eq, Generic, Hashable)

-- | Group errors together, attaching a location if one is available.
groupErrors :: (IsError e, ApErrors e m, HasLocation l) => l -> m a -> m a
groupErrors item = mapError $ \es -> case allErrors es of
    Group Nothing  es' :| [] -> singleError $ Group (item ^? location) es'
    Group (Just _) _   :| [] -> es
    _                        -> singleError $ Group (item ^? location) es

-- | 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.
liftError1 :: (IsError e, ApErrors e m) => Error e -> m a
liftError1 = liftError . singleError
{-# INLINE liftError1 #-}

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