{-# language BangPatterns #-}
{-# language OverloadedStrings #-}
{-# language FlexibleContexts #-}

module Syntax.Error 
  ( ppError
  ) where

import Data.Maybe (isNothing)
import Data.List as List
import Data.List.NonEmpty as NE
import Data.Proxy
import qualified Data.Set as E
import Data.Text as Text
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import Text.Megaparsec.Error
import Text.Megaparsec.Stream
import Text.Megaparsec.Pos
import Syntax.Located

ppError :: (Ord a, ShowToken (Located a), ShowErrorComponent e) => Text -> ParseError (Located a) e -> Doc AnsiStyle
ppError s e = vsep
  [ sourcePosStackPrettier (errorPos e) <> ":"
  , pretty padding     <> bar 
  , pretty lineNumber <+> bar <+> rline
  , pretty padding     <> bar <+> pretty rpadding <> cursor
  , parseErrorTextPrettier e
  ] where
  bar = annotate (color Yellow) "|"
  cursor = annotate (color Green) "^" -- TODO: extend as a span to the right
  epos = NE.last (errorPos e)
  lineNumber = show $ unPos $ sourceLine epos
  padding    = spaces $ Prelude.length lineNumber + 1
  rpadding   = spaces $ unPos (sourceColumn epos) - 1
  spaces n = justifyLeft n ' ' ""
  rline = case rline' of
    [] -> annotate (color Red) "<empty line>"
    xs -> pretty $ expandTab (mkPos 8) xs
  rline'     = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy Text) $ selectLine (sourceLine epos) s

selectLine
  :: Pos  -- ^ Number of line to select
  -> Text -- ^ Input stream
  -> Text -- ^ Selected line
selectLine l = go pos1 where
  go !n !s
    | n == l    = fst (takeWhile_ notNewline s)
    | otherwise = go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s))
  notNewline = not . tokenIsNewline
  stripNewline s = maybe s snd (take1_ s)

expandTab :: Pos -> String -> String
expandTab w' = go 0 where
  go 0 []        = []
  go 0 ('\t':xs) = go w xs
  go 0 (x:xs)    = x : go 0 xs
  go !n xs       = ' ' : go (n - 1) xs
  w              = unPos w'

parseErrorTextPrettier :: (Ord t, ShowToken t, ShowErrorComponent e)
  => ParseError t e -- ^ Parse error to render
  -> Doc AnsiStyle -- ^ Result of rendering
parseErrorTextPrettier (TrivialError _ us ps) =
  if isNothing us && E.null ps
    then "unknown parse error\n"
    else messageItemsPrettier "unexpected " (maybe E.empty E.singleton us) <>
         messageItemsPrettier "expecting " ps
parseErrorTextPrettier (FancyError _ xs) =
  if E.null xs
    then "unknown fancy parse error\n"
    else vsep (pretty . showErrorComponent <$> E.toAscList xs)

messageItemsPrettier :: ShowErrorComponent a
  => Doc AnsiStyle     -- ^ Prefix to prepend
  -> E.Set a           -- ^ Collection of messages
  -> Doc AnsiStyle     -- ^ Result of rendering
messageItemsPrettier prefix ts
  | E.null ts = mempty
  | otherwise =
    let f = orList . NE.fromList . fmap pretty . E.toAscList . E.map showErrorComponent
    in prefix <> f ts <> "\n"

orList :: NonEmpty (Doc a) -> Doc a
orList (x:|[])  = x
orList (x:|[y]) = x <> " or " <> y
orList xs       = sep (List.intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs

sourcePosStackPrettier :: NonEmpty SourcePos -> Doc AnsiStyle
sourcePosStackPrettier ms = mconcat (f <$> rest) <> sourcePosPrettier pos
  where
    pos :| rest' = ms
    rest = Prelude.reverse rest'
    f p = "in file included from " <> sourcePosPrettier p <> ",\n"

sourcePosPrettier :: SourcePos -> Doc AnsiStyle
sourcePosPrettier (SourcePos n l c)
  | Prelude.null n = annotate bold showLC
  | otherwise = annotate bold $ pretty n <> ":" <> showLC
  where showLC = pretty $ show (unPos l) <> ":" <> show (unPos c)