Error.hs

module Descript.Misc.Build.Read.Parse.Error
  ( RangedErrorMsg (..)
  , RangedError (..)
  , ParseError
  , ParseResult
  , ParseResultT
  , splitParseError
  , parseErrorSummary
  ) where

import Descript.Misc.Build.Read.Parse.Loc
import Descript.Misc.Build.Read.File
import Descript.Misc.Loc
import Descript.Misc.Error
import Descript.Misc.Summary
import qualified Text.Megaparsec.Error as Parsec
import qualified Text.Megaparsec.Pos as Parsec
import Data.Maybe
import Core.Data.List
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Set as Set

data RangedErrorMsg
  = RangedErrorMsg
  { itemRange :: Range
  , itemMsg :: String
  } deriving (Eq, Ord, Read, Show)

data RangedError
  = RangedError
  { errorRange :: Range
  , rangedErrorExpected :: String
  , rangedErrorActual :: String
  } deriving (Eq, Ord, Read, Show)

type ParseError t = Parsec.ParseError t RangedError

type ParseResult a = Result (ParseError Char) a

type ParseResultT u a = ResultT (ParseError Char) u a

instance Parsec.ShowErrorComponent RangedError where
  showErrorComponent (RangedError _ expected actual)
    = "expected " ++ expected ++ ", got " ++ actual

instance Summary RangedError where
  summary x = summary (errorRange x) ++ ": " ++ Parsec.showErrorComponent x

-- | Takes components with ranges ('RangedError's) and describes them
-- with their ranges, takes all other components and describes them
-- together with the range starting and ending at the general error's
-- position.
splitParseError :: (Ord a, Parsec.ShowToken a)
                => ParseError a
                -> [RangedErrorMsg]
splitParseError err@(Parsec.TrivialError (gpos :| _) _ _) =
  [ RangedErrorMsg
      { itemRange = singletonRange $ posToLoc gpos
      , itemMsg = Parsec.parseErrorTextPretty err
      }
  ]
splitParseError (Parsec.FancyError (gpos :| _) items)
  = errItemsGenMsg gpos items' ?: errItemRangedMsgs items'
  where items' = Set.toList items

errItemsGenMsg :: Parsec.SourcePos
               -> [Parsec.ErrorFancy RangedError]
               -> Maybe RangedErrorMsg
errItemsGenMsg gpos
  = fmap (mkGenRangedMsg gpos . msgToStr)
  . foldMap (fmap strToMsg . errItemGenMsg)

errItemGenMsg :: Parsec.ErrorFancy RangedError
              -> Maybe String
errItemGenMsg (Parsec.ErrorCustom _) = Nothing
errItemGenMsg err = Just $ Parsec.showErrorComponent err

errItemRangedMsgs :: [Parsec.ErrorFancy RangedError] -> [RangedErrorMsg]
errItemRangedMsgs = mapMaybe errItemRangedMsg

errItemRangedMsg :: Parsec.ErrorFancy RangedError -> Maybe RangedErrorMsg
errItemRangedMsg (Parsec.ErrorCustom rangedErr)
  = Just $ rangedErrMsg rangedErr
errItemRangedMsg _ = Nothing

rangedErrMsg :: RangedError -> RangedErrorMsg
rangedErrMsg err
  = RangedErrorMsg
  { itemRange = errorRange err
  , itemMsg = Parsec.showErrorComponent err
  }

mkGenRangedMsg :: Parsec.SourcePos -> String -> RangedErrorMsg
mkGenRangedMsg gpos desc
  = RangedErrorMsg
  { itemRange = singletonRange $ posToLoc gpos
  , itemMsg = desc
  }

-- | Summarizes a parse error in a larger context (e.g. build error).
parseErrorSummary :: SFile -> ParseError Char -> String
parseErrorSummary file err = "parse error: " ++ summaryF file err