content: {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  module Data.Error
    ( Error (..)
    , formatError
    , makeError
    , showExpectation
    , showExcerpt
    , withSGRCode
    -- * Flags affecting 'Error' values
    , LogPrintSource (..)
    , Colourize (..)
    ) where
  
  import Control.Exception (Exception)
  import Data.ByteString.Char8 (unpack)
  import Data.Foldable
  import Data.Ix (inRange)
  import Data.List (intersperse, isSuffixOf)
  import GHC.Stack
  import System.Console.ANSI
  
  import           Data.Blob
  import           Data.Flag as Flag
  import qualified Source.Source as Source
  import           Source.Span
  
  data LogPrintSource = LogPrintSource
  data Colourize = Colourize
  
  -- | Rather than using the Error constructor directly, you probably
  -- want to call 'makeError', which takes care of inserting the call
  -- stack for you.
  data Error grammar = Error
    { errorSpan      :: Span
    , errorExpected  :: [grammar]
    , errorActual    :: Maybe grammar
    , errorCallStack :: CallStack
    } deriving (Show, Functor)
  
  -- | This instance does not take into account the call stack.
  instance Eq grammar => Eq (Error grammar) where
    (Error s e a _) == (Error s' e' a' _) = (s == s') && (e == e') && (a == a')
  
  instance Exception (Error String)
  
  makeError :: HasCallStack => Span -> [grammar] -> Maybe grammar -> Error grammar
  makeError s e a = withFrozenCallStack (Error s e a callStack)
  
  -- | Format an 'Error', optionally with reference to the source where it occurred.
  formatError :: Flag LogPrintSource -> Flag Colourize -> Blob -> Error String -> String
  formatError includeSource colourize blob Error{..}
    = ($ "")
    $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan path errorSpan . showString ": ")
    . withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation colourize errorExpected errorActual . showChar '\n'
    . (if Flag.toBool LogPrintSource includeSource then showExcerpt colourize errorSpan blob else id)
    . showCallStack colourize callStack . showChar '\n'
    where
      path = Just $ if Flag.toBool LogPrintSource includeSource then blobFilePath blob else "<filtered>"
  
  showExcerpt :: Flag Colourize -> Span -> Blob -> ShowS
  showExcerpt colourize Span{..} Blob{..}
    = showString context . (if "\n" `isSuffixOf` context then id else showChar '\n')
    . showString (replicate (caretPaddingWidth + lineNumberDigits) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showString caret) . showChar '\n'
    where context = fold contextLines
          contextLines = [ showLineNumber i <> ": " <> unpack (Source.bytes l)
                         | (i, l) <- zip [1..] (Source.lines blobSource)
                         , inRange (line start - 2, line start) i
                         ]
          showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s
          lineNumberDigits = succ (floor (logBase 10 (fromIntegral (line start) :: Double)))
          caretPaddingWidth = succ (column start)
          caret | line start == line end = replicate (max 1 (column end - column start)) '^'
                | otherwise                            = "^..."
  
  withSGRCode :: Flag Colourize -> [SGR] -> ShowS -> ShowS
  withSGRCode useColour code content
    | Flag.toBool Colourize useColour = showString (setSGRCode code) . content . showString (setSGRCode [])
    | otherwise = content
  
  showExpectation :: Flag Colourize -> [String] -> Maybe String -> ShowS
  showExpectation colourize = go
    where go [] Nothing = showString "no rule to match at " . showActual "end of branch"
          go expected Nothing = showString "expected " . showSymbols colourize expected . showString " at " . showActual "end of branch"
          go expected (Just actual) = showString "expected " . showSymbols colourize expected . showString ", but got " . showActual actual
          showActual = withSGRCode colourize [SetColor Foreground Vivid Green] . showString
  
  showSymbols :: Flag Colourize -> [String] -> ShowS
  showSymbols colourize = go
    where go []        = showString "end of input nodes"
          go [symbol]  = showSymbol symbol
          go [a, b]    = showSymbol a . showString " or " . showSymbol b
          go [a, b, c] = showSymbol a . showString ", " . showSymbol b . showString ", or " . showSymbol c
          go (h:t)     = showSymbol h . showString ", " . go t
          showSymbol = withSGRCode colourize [SetColor Foreground Vivid Red] . showString
  
  showSpan :: Maybe FilePath -> Span -> ShowS
  showSpan path Span{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . (if start == end then showPos start else showPos start . showChar '-' . showPos end)
    where showPos Pos{..} = shows line . showChar ':' . shows column
  
  showCallStack :: Flag Colourize -> CallStack -> ShowS
  showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack))
  
  showCallSite :: Flag Colourize -> String -> SrcLoc -> ShowS
  showCallSite colourize symbol loc@SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (spanFromSrcLoc loc)))
  